ada-lang.c revision 1.8
1/* Ada language support routines for GDB, the GNU debugger. 2 3 Copyright (C) 1992-2019 Free Software Foundation, Inc. 4 5 This file is part of GDB. 6 7 This program is free software; you can redistribute it and/or modify 8 it under the terms of the GNU General Public License as published by 9 the Free Software Foundation; either version 3 of the License, or 10 (at your option) any later version. 11 12 This program is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with this program. If not, see <http://www.gnu.org/licenses/>. */ 19 20 21#include "defs.h" 22#include <ctype.h> 23#include "demangle.h" 24#include "gdb_regex.h" 25#include "frame.h" 26#include "symtab.h" 27#include "gdbtypes.h" 28#include "gdbcmd.h" 29#include "expression.h" 30#include "parser-defs.h" 31#include "language.h" 32#include "varobj.h" 33#include "c-lang.h" 34#include "inferior.h" 35#include "symfile.h" 36#include "objfiles.h" 37#include "breakpoint.h" 38#include "gdbcore.h" 39#include "hashtab.h" 40#include "gdb_obstack.h" 41#include "ada-lang.h" 42#include "completer.h" 43#include <sys/stat.h> 44#include "ui-out.h" 45#include "block.h" 46#include "infcall.h" 47#include "dictionary.h" 48#include "annotate.h" 49#include "valprint.h" 50#include "source.h" 51#include "observable.h" 52#include "common/vec.h" 53#include "stack.h" 54#include "common/gdb_vecs.h" 55#include "typeprint.h" 56#include "namespace.h" 57 58#include "psymtab.h" 59#include "value.h" 60#include "mi/mi-common.h" 61#include "arch-utils.h" 62#include "cli/cli-utils.h" 63#include "common/function-view.h" 64#include "common/byte-vector.h" 65#include <algorithm> 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 75static struct type *desc_base_type (struct type *); 76 77static struct type *desc_bounds_type (struct type *); 78 79static struct value *desc_bounds (struct value *); 80 81static int fat_pntr_bounds_bitpos (struct type *); 82 83static int fat_pntr_bounds_bitsize (struct type *); 84 85static struct type *desc_data_target_type (struct type *); 86 87static struct value *desc_data (struct value *); 88 89static int fat_pntr_data_bitpos (struct type *); 90 91static int fat_pntr_data_bitsize (struct type *); 92 93static struct value *desc_one_bound (struct value *, int, int); 94 95static int desc_bound_bitpos (struct type *, int, int); 96 97static int desc_bound_bitsize (struct type *, int, int); 98 99static struct type *desc_index_type (struct type *, int); 100 101static int desc_arity (struct type *); 102 103static int ada_type_match (struct type *, struct type *, int); 104 105static int ada_args_match (struct symbol *, struct value **, int); 106 107static struct value *make_array_descriptor (struct type *, struct value *); 108 109static void ada_add_block_symbols (struct obstack *, 110 const struct block *, 111 const lookup_name_info &lookup_name, 112 domain_enum, struct objfile *); 113 114static void ada_add_all_symbols (struct obstack *, const struct block *, 115 const lookup_name_info &lookup_name, 116 domain_enum, int, int *); 117 118static int is_nonfunction (struct block_symbol *, int); 119 120static void add_defn_to_vec (struct obstack *, struct symbol *, 121 const struct block *); 122 123static int num_defns_collected (struct obstack *); 124 125static struct block_symbol *defns_collected (struct obstack *, int); 126 127static struct value *resolve_subexp (expression_up *, int *, int, 128 struct type *); 129 130static void replace_operator_with_call (expression_up *, int, int, int, 131 struct symbol *, const struct block *); 132 133static int possible_user_operator_p (enum exp_opcode, struct value **); 134 135static const char *ada_op_name (enum exp_opcode); 136 137static const char *ada_decoded_op_name (enum exp_opcode); 138 139static int numeric_type_p (struct type *); 140 141static int integer_type_p (struct type *); 142 143static int scalar_type_p (struct type *); 144 145static int discrete_type_p (struct type *); 146 147static enum ada_renaming_category parse_old_style_renaming (struct type *, 148 const char **, 149 int *, 150 const char **); 151 152static struct symbol *find_old_style_renaming_symbol (const char *, 153 const struct block *); 154 155static struct type *ada_lookup_struct_elt_type (struct type *, const char *, 156 int, int); 157 158static struct value *evaluate_subexp_type (struct expression *, int *); 159 160static struct type *ada_find_parallel_type_with_name (struct type *, 161 const char *); 162 163static int is_dynamic_field (struct type *, int); 164 165static struct type *to_fixed_variant_branch_type (struct type *, 166 const gdb_byte *, 167 CORE_ADDR, struct value *); 168 169static struct type *to_fixed_array_type (struct type *, struct value *, int); 170 171static struct type *to_fixed_range_type (struct type *, struct value *); 172 173static struct type *to_static_fixed_type (struct type *); 174static struct type *static_unwrap_type (struct type *type); 175 176static struct value *unwrap_value (struct value *); 177 178static struct type *constrained_packed_array_type (struct type *, long *); 179 180static struct type *decode_constrained_packed_array_type (struct type *); 181 182static long decode_packed_array_bitsize (struct type *); 183 184static struct value *decode_constrained_packed_array (struct value *); 185 186static int ada_is_packed_array_type (struct type *); 187 188static int ada_is_unconstrained_packed_array_type (struct type *); 189 190static struct value *value_subscript_packed (struct value *, int, 191 struct value **); 192 193static struct value *coerce_unspec_val_to_type (struct value *, 194 struct type *); 195 196static int lesseq_defined_than (struct symbol *, struct symbol *); 197 198static int equiv_types (struct type *, struct type *); 199 200static int is_name_suffix (const char *); 201 202static int advance_wild_match (const char **, const char *, int); 203 204static bool wild_match (const char *name, const char *patn); 205 206static struct value *ada_coerce_ref (struct value *); 207 208static LONGEST pos_atr (struct value *); 209 210static struct value *value_pos_atr (struct type *, struct value *); 211 212static struct value *value_val_atr (struct type *, struct value *); 213 214static struct symbol *standard_lookup (const char *, const struct block *, 215 domain_enum); 216 217static struct value *ada_search_struct_field (const char *, struct value *, int, 218 struct type *); 219 220static struct value *ada_value_primitive_field (struct value *, int, int, 221 struct type *); 222 223static int find_struct_field (const char *, struct type *, int, 224 struct type **, int *, int *, int *, int *); 225 226static int ada_resolve_function (struct block_symbol *, int, 227 struct value **, int, const char *, 228 struct type *); 229 230static int ada_is_direct_array_type (struct type *); 231 232static void ada_language_arch_info (struct gdbarch *, 233 struct language_arch_info *); 234 235static struct value *ada_index_struct_field (int, struct value *, int, 236 struct type *); 237 238static struct value *assign_aggregate (struct value *, struct value *, 239 struct expression *, 240 int *, enum noside); 241 242static void aggregate_assign_from_choices (struct value *, struct value *, 243 struct expression *, 244 int *, LONGEST *, int *, 245 int, LONGEST, LONGEST); 246 247static void aggregate_assign_positional (struct value *, struct value *, 248 struct expression *, 249 int *, LONGEST *, int *, int, 250 LONGEST, LONGEST); 251 252 253static void aggregate_assign_others (struct value *, struct value *, 254 struct expression *, 255 int *, LONGEST *, int, LONGEST, LONGEST); 256 257 258static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int); 259 260 261static struct value *ada_evaluate_subexp (struct type *, struct expression *, 262 int *, enum noside); 263 264static void ada_forward_operator_length (struct expression *, int, int *, 265 int *); 266 267static struct type *ada_find_any_type (const char *name); 268 269static symbol_name_matcher_ftype *ada_get_symbol_name_matcher 270 (const lookup_name_info &lookup_name); 271 272 273 274/* The result of a symbol lookup to be stored in our symbol cache. */ 275 276struct cache_entry 277{ 278 /* The name used to perform the lookup. */ 279 const char *name; 280 /* The namespace used during the lookup. */ 281 domain_enum domain; 282 /* The symbol returned by the lookup, or NULL if no matching symbol 283 was found. */ 284 struct symbol *sym; 285 /* The block where the symbol was found, or NULL if no matching 286 symbol was found. */ 287 const struct block *block; 288 /* A pointer to the next entry with the same hash. */ 289 struct cache_entry *next; 290}; 291 292/* The Ada symbol cache, used to store the result of Ada-mode symbol 293 lookups in the course of executing the user's commands. 294 295 The cache is implemented using a simple, fixed-sized hash. 296 The size is fixed on the grounds that there are not likely to be 297 all that many symbols looked up during any given session, regardless 298 of the size of the symbol table. If we decide to go to a resizable 299 table, let's just use the stuff from libiberty instead. */ 300 301#define HASH_SIZE 1009 302 303struct ada_symbol_cache 304{ 305 /* An obstack used to store the entries in our cache. */ 306 struct obstack cache_space; 307 308 /* The root of the hash table used to implement our symbol cache. */ 309 struct cache_entry *root[HASH_SIZE]; 310}; 311 312static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache); 313 314/* Maximum-sized dynamic type. */ 315static unsigned int varsize_limit; 316 317static const char ada_completer_word_break_characters[] = 318#ifdef VMS 319 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-"; 320#else 321 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-"; 322#endif 323 324/* The name of the symbol to use to get the name of the main subprogram. */ 325static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[] 326 = "__gnat_ada_main_program_name"; 327 328/* Limit on the number of warnings to raise per expression evaluation. */ 329static int warning_limit = 2; 330 331/* Number of warning messages issued; reset to 0 by cleanups after 332 expression evaluation. */ 333static int warnings_issued = 0; 334 335static const char *known_runtime_file_name_patterns[] = { 336 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL 337}; 338 339static const char *known_auxiliary_function_name_patterns[] = { 340 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL 341}; 342 343/* Maintenance-related settings for this module. */ 344 345static struct cmd_list_element *maint_set_ada_cmdlist; 346static struct cmd_list_element *maint_show_ada_cmdlist; 347 348/* Implement the "maintenance set ada" (prefix) command. */ 349 350static void 351maint_set_ada_cmd (const char *args, int from_tty) 352{ 353 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands, 354 gdb_stdout); 355} 356 357/* Implement the "maintenance show ada" (prefix) command. */ 358 359static void 360maint_show_ada_cmd (const char *args, int from_tty) 361{ 362 cmd_show_list (maint_show_ada_cmdlist, from_tty, ""); 363} 364 365/* The "maintenance ada set/show ignore-descriptive-type" value. */ 366 367static int ada_ignore_descriptive_types_p = 0; 368 369 /* Inferior-specific data. */ 370 371/* Per-inferior data for this module. */ 372 373struct ada_inferior_data 374{ 375 /* The ada__tags__type_specific_data type, which is used when decoding 376 tagged types. With older versions of GNAT, this type was directly 377 accessible through a component ("tsd") in the object tag. But this 378 is no longer the case, so we cache it for each inferior. */ 379 struct type *tsd_type; 380 381 /* The exception_support_info data. This data is used to determine 382 how to implement support for Ada exception catchpoints in a given 383 inferior. */ 384 const struct exception_support_info *exception_info; 385}; 386 387/* Our key to this module's inferior data. */ 388static const struct inferior_data *ada_inferior_data; 389 390/* A cleanup routine for our inferior data. */ 391static void 392ada_inferior_data_cleanup (struct inferior *inf, void *arg) 393{ 394 struct ada_inferior_data *data; 395 396 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data); 397 if (data != NULL) 398 xfree (data); 399} 400 401/* Return our inferior data for the given inferior (INF). 402 403 This function always returns a valid pointer to an allocated 404 ada_inferior_data structure. If INF's inferior data has not 405 been previously set, this functions creates a new one with all 406 fields set to zero, sets INF's inferior to it, and then returns 407 a pointer to that newly allocated ada_inferior_data. */ 408 409static struct ada_inferior_data * 410get_ada_inferior_data (struct inferior *inf) 411{ 412 struct ada_inferior_data *data; 413 414 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data); 415 if (data == NULL) 416 { 417 data = XCNEW (struct ada_inferior_data); 418 set_inferior_data (inf, ada_inferior_data, data); 419 } 420 421 return data; 422} 423 424/* Perform all necessary cleanups regarding our module's inferior data 425 that is required after the inferior INF just exited. */ 426 427static void 428ada_inferior_exit (struct inferior *inf) 429{ 430 ada_inferior_data_cleanup (inf, NULL); 431 set_inferior_data (inf, ada_inferior_data, NULL); 432} 433 434 435 /* program-space-specific data. */ 436 437/* This module's per-program-space data. */ 438struct ada_pspace_data 439{ 440 /* The Ada symbol cache. */ 441 struct ada_symbol_cache *sym_cache; 442}; 443 444/* Key to our per-program-space data. */ 445static const struct program_space_data *ada_pspace_data_handle; 446 447/* Return this module's data for the given program space (PSPACE). 448 If not is found, add a zero'ed one now. 449 450 This function always returns a valid object. */ 451 452static struct ada_pspace_data * 453get_ada_pspace_data (struct program_space *pspace) 454{ 455 struct ada_pspace_data *data; 456 457 data = ((struct ada_pspace_data *) 458 program_space_data (pspace, ada_pspace_data_handle)); 459 if (data == NULL) 460 { 461 data = XCNEW (struct ada_pspace_data); 462 set_program_space_data (pspace, ada_pspace_data_handle, data); 463 } 464 465 return data; 466} 467 468/* The cleanup callback for this module's per-program-space data. */ 469 470static void 471ada_pspace_data_cleanup (struct program_space *pspace, void *data) 472{ 473 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data; 474 475 if (pspace_data->sym_cache != NULL) 476 ada_free_symbol_cache (pspace_data->sym_cache); 477 xfree (pspace_data); 478} 479 480 /* Utilities */ 481 482/* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after 483 all typedef layers have been peeled. Otherwise, return TYPE. 484 485 Normally, we really expect a typedef type to only have 1 typedef layer. 486 In other words, we really expect the target type of a typedef type to be 487 a non-typedef type. This is particularly true for Ada units, because 488 the language does not have a typedef vs not-typedef distinction. 489 In that respect, the Ada compiler has been trying to eliminate as many 490 typedef definitions in the debugging information, since they generally 491 do not bring any extra information (we still use typedef under certain 492 circumstances related mostly to the GNAT encoding). 493 494 Unfortunately, we have seen situations where the debugging information 495 generated by the compiler leads to such multiple typedef layers. For 496 instance, consider the following example with stabs: 497 498 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...] 499 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0 500 501 This is an error in the debugging information which causes type 502 pck__float_array___XUP to be defined twice, and the second time, 503 it is defined as a typedef of a typedef. 504 505 This is on the fringe of legality as far as debugging information is 506 concerned, and certainly unexpected. But it is easy to handle these 507 situations correctly, so we can afford to be lenient in this case. */ 508 509static struct type * 510ada_typedef_target_type (struct type *type) 511{ 512 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 513 type = TYPE_TARGET_TYPE (type); 514 return type; 515} 516 517/* Given DECODED_NAME a string holding a symbol name in its 518 decoded form (ie using the Ada dotted notation), returns 519 its unqualified name. */ 520 521static const char * 522ada_unqualified_name (const char *decoded_name) 523{ 524 const char *result; 525 526 /* If the decoded name starts with '<', it means that the encoded 527 name does not follow standard naming conventions, and thus that 528 it is not your typical Ada symbol name. Trying to unqualify it 529 is therefore pointless and possibly erroneous. */ 530 if (decoded_name[0] == '<') 531 return decoded_name; 532 533 result = strrchr (decoded_name, '.'); 534 if (result != NULL) 535 result++; /* Skip the dot... */ 536 else 537 result = decoded_name; 538 539 return result; 540} 541 542/* Return a string starting with '<', followed by STR, and '>'. */ 543 544static std::string 545add_angle_brackets (const char *str) 546{ 547 return string_printf ("<%s>", str); 548} 549 550static const char * 551ada_get_gdb_completer_word_break_characters (void) 552{ 553 return ada_completer_word_break_characters; 554} 555 556/* Print an array element index using the Ada syntax. */ 557 558static void 559ada_print_array_index (struct value *index_value, struct ui_file *stream, 560 const struct value_print_options *options) 561{ 562 LA_VALUE_PRINT (index_value, stream, options); 563 fprintf_filtered (stream, " => "); 564} 565 566/* la_watch_location_expression for Ada. */ 567 568gdb::unique_xmalloc_ptr<char> 569ada_watch_location_expression (struct type *type, CORE_ADDR addr) 570{ 571 type = check_typedef (TYPE_TARGET_TYPE (check_typedef (type))); 572 std::string name = type_to_string (type); 573 return gdb::unique_xmalloc_ptr<char> 574 (xstrprintf ("{%s} %s", name.c_str (), core_addr_to_string (addr))); 575} 576 577/* Assuming VECT points to an array of *SIZE objects of size 578 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects, 579 updating *SIZE as necessary and returning the (new) array. */ 580 581void * 582grow_vect (void *vect, size_t *size, size_t min_size, int element_size) 583{ 584 if (*size < min_size) 585 { 586 *size *= 2; 587 if (*size < min_size) 588 *size = min_size; 589 vect = xrealloc (vect, *size * element_size); 590 } 591 return vect; 592} 593 594/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing 595 suffix of FIELD_NAME beginning "___". */ 596 597static int 598field_name_match (const char *field_name, const char *target) 599{ 600 int len = strlen (target); 601 602 return 603 (strncmp (field_name, target, len) == 0 604 && (field_name[len] == '\0' 605 || (startswith (field_name + len, "___") 606 && strcmp (field_name + strlen (field_name) - 6, 607 "___XVN") != 0))); 608} 609 610 611/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to 612 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME, 613 and return its index. This function also handles fields whose name 614 have ___ suffixes because the compiler sometimes alters their name 615 by adding such a suffix to represent fields with certain constraints. 616 If the field could not be found, return a negative number if 617 MAYBE_MISSING is set. Otherwise raise an error. */ 618 619int 620ada_get_field_index (const struct type *type, const char *field_name, 621 int maybe_missing) 622{ 623 int fieldno; 624 struct type *struct_type = check_typedef ((struct type *) type); 625 626 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++) 627 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name)) 628 return fieldno; 629 630 if (!maybe_missing) 631 error (_("Unable to find field %s in struct %s. Aborting"), 632 field_name, TYPE_NAME (struct_type)); 633 634 return -1; 635} 636 637/* The length of the prefix of NAME prior to any "___" suffix. */ 638 639int 640ada_name_prefix_len (const char *name) 641{ 642 if (name == NULL) 643 return 0; 644 else 645 { 646 const char *p = strstr (name, "___"); 647 648 if (p == NULL) 649 return strlen (name); 650 else 651 return p - name; 652 } 653} 654 655/* Return non-zero if SUFFIX is a suffix of STR. 656 Return zero if STR is null. */ 657 658static int 659is_suffix (const char *str, const char *suffix) 660{ 661 int len1, len2; 662 663 if (str == NULL) 664 return 0; 665 len1 = strlen (str); 666 len2 = strlen (suffix); 667 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0); 668} 669 670/* The contents of value VAL, treated as a value of type TYPE. The 671 result is an lval in memory if VAL is. */ 672 673static struct value * 674coerce_unspec_val_to_type (struct value *val, struct type *type) 675{ 676 type = ada_check_typedef (type); 677 if (value_type (val) == type) 678 return val; 679 else 680 { 681 struct value *result; 682 683 /* Make sure that the object size is not unreasonable before 684 trying to allocate some memory for it. */ 685 ada_ensure_varsize_limit (type); 686 687 if (value_lazy (val) 688 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))) 689 result = allocate_value_lazy (type); 690 else 691 { 692 result = allocate_value (type); 693 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type)); 694 } 695 set_value_component_location (result, val); 696 set_value_bitsize (result, value_bitsize (val)); 697 set_value_bitpos (result, value_bitpos (val)); 698 set_value_address (result, value_address (val)); 699 return result; 700 } 701} 702 703static const gdb_byte * 704cond_offset_host (const gdb_byte *valaddr, long offset) 705{ 706 if (valaddr == NULL) 707 return NULL; 708 else 709 return valaddr + offset; 710} 711 712static CORE_ADDR 713cond_offset_target (CORE_ADDR address, long offset) 714{ 715 if (address == 0) 716 return 0; 717 else 718 return address + offset; 719} 720 721/* Issue a warning (as for the definition of warning in utils.c, but 722 with exactly one argument rather than ...), unless the limit on the 723 number of warnings has passed during the evaluation of the current 724 expression. */ 725 726/* FIXME: cagney/2004-10-10: This function is mimicking the behavior 727 provided by "complaint". */ 728static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2); 729 730static void 731lim_warning (const char *format, ...) 732{ 733 va_list args; 734 735 va_start (args, format); 736 warnings_issued += 1; 737 if (warnings_issued <= warning_limit) 738 vwarning (format, args); 739 740 va_end (args); 741} 742 743/* Issue an error if the size of an object of type T is unreasonable, 744 i.e. if it would be a bad idea to allocate a value of this type in 745 GDB. */ 746 747void 748ada_ensure_varsize_limit (const struct type *type) 749{ 750 if (TYPE_LENGTH (type) > varsize_limit) 751 error (_("object size is larger than varsize-limit")); 752} 753 754/* Maximum value of a SIZE-byte signed integer type. */ 755static LONGEST 756max_of_size (int size) 757{ 758 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2); 759 760 return top_bit | (top_bit - 1); 761} 762 763/* Minimum value of a SIZE-byte signed integer type. */ 764static LONGEST 765min_of_size (int size) 766{ 767 return -max_of_size (size) - 1; 768} 769 770/* Maximum value of a SIZE-byte unsigned integer type. */ 771static ULONGEST 772umax_of_size (int size) 773{ 774 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1); 775 776 return top_bit | (top_bit - 1); 777} 778 779/* Maximum value of integral type T, as a signed quantity. */ 780static LONGEST 781max_of_type (struct type *t) 782{ 783 if (TYPE_UNSIGNED (t)) 784 return (LONGEST) umax_of_size (TYPE_LENGTH (t)); 785 else 786 return max_of_size (TYPE_LENGTH (t)); 787} 788 789/* Minimum value of integral type T, as a signed quantity. */ 790static LONGEST 791min_of_type (struct type *t) 792{ 793 if (TYPE_UNSIGNED (t)) 794 return 0; 795 else 796 return min_of_size (TYPE_LENGTH (t)); 797} 798 799/* The largest value in the domain of TYPE, a discrete type, as an integer. */ 800LONGEST 801ada_discrete_type_high_bound (struct type *type) 802{ 803 type = resolve_dynamic_type (type, NULL, 0); 804 switch (TYPE_CODE (type)) 805 { 806 case TYPE_CODE_RANGE: 807 return TYPE_HIGH_BOUND (type); 808 case TYPE_CODE_ENUM: 809 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1); 810 case TYPE_CODE_BOOL: 811 return 1; 812 case TYPE_CODE_CHAR: 813 case TYPE_CODE_INT: 814 return max_of_type (type); 815 default: 816 error (_("Unexpected type in ada_discrete_type_high_bound.")); 817 } 818} 819 820/* The smallest value in the domain of TYPE, a discrete type, as an integer. */ 821LONGEST 822ada_discrete_type_low_bound (struct type *type) 823{ 824 type = resolve_dynamic_type (type, NULL, 0); 825 switch (TYPE_CODE (type)) 826 { 827 case TYPE_CODE_RANGE: 828 return TYPE_LOW_BOUND (type); 829 case TYPE_CODE_ENUM: 830 return TYPE_FIELD_ENUMVAL (type, 0); 831 case TYPE_CODE_BOOL: 832 return 0; 833 case TYPE_CODE_CHAR: 834 case TYPE_CODE_INT: 835 return min_of_type (type); 836 default: 837 error (_("Unexpected type in ada_discrete_type_low_bound.")); 838 } 839} 840 841/* The identity on non-range types. For range types, the underlying 842 non-range scalar type. */ 843 844static struct type * 845get_base_type (struct type *type) 846{ 847 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE) 848 { 849 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL) 850 return type; 851 type = TYPE_TARGET_TYPE (type); 852 } 853 return type; 854} 855 856/* Return a decoded version of the given VALUE. This means returning 857 a value whose type is obtained by applying all the GNAT-specific 858 encondings, making the resulting type a static but standard description 859 of the initial type. */ 860 861struct value * 862ada_get_decoded_value (struct value *value) 863{ 864 struct type *type = ada_check_typedef (value_type (value)); 865 866 if (ada_is_array_descriptor_type (type) 867 || (ada_is_constrained_packed_array_type (type) 868 && TYPE_CODE (type) != TYPE_CODE_PTR)) 869 { 870 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */ 871 value = ada_coerce_to_simple_array_ptr (value); 872 else 873 value = ada_coerce_to_simple_array (value); 874 } 875 else 876 value = ada_to_fixed_value (value); 877 878 return value; 879} 880 881/* Same as ada_get_decoded_value, but with the given TYPE. 882 Because there is no associated actual value for this type, 883 the resulting type might be a best-effort approximation in 884 the case of dynamic types. */ 885 886struct type * 887ada_get_decoded_type (struct type *type) 888{ 889 type = to_static_fixed_type (type); 890 if (ada_is_constrained_packed_array_type (type)) 891 type = ada_coerce_to_simple_array_type (type); 892 return type; 893} 894 895 896 897 /* Language Selection */ 898 899/* If the main program is in Ada, return language_ada, otherwise return LANG 900 (the main program is in Ada iif the adainit symbol is found). */ 901 902enum language 903ada_update_initial_language (enum language lang) 904{ 905 if (lookup_minimal_symbol ("adainit", (const char *) NULL, 906 (struct objfile *) NULL).minsym != NULL) 907 return language_ada; 908 909 return lang; 910} 911 912/* If the main procedure is written in Ada, then return its name. 913 The result is good until the next call. Return NULL if the main 914 procedure doesn't appear to be in Ada. */ 915 916char * 917ada_main_name (void) 918{ 919 struct bound_minimal_symbol msym; 920 static gdb::unique_xmalloc_ptr<char> main_program_name; 921 922 /* For Ada, the name of the main procedure is stored in a specific 923 string constant, generated by the binder. Look for that symbol, 924 extract its address, and then read that string. If we didn't find 925 that string, then most probably the main procedure is not written 926 in Ada. */ 927 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL); 928 929 if (msym.minsym != NULL) 930 { 931 CORE_ADDR main_program_name_addr; 932 int err_code; 933 934 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym); 935 if (main_program_name_addr == 0) 936 error (_("Invalid address for Ada main program name.")); 937 938 target_read_string (main_program_name_addr, &main_program_name, 939 1024, &err_code); 940 941 if (err_code != 0) 942 return NULL; 943 return main_program_name.get (); 944 } 945 946 /* The main procedure doesn't seem to be in Ada. */ 947 return NULL; 948} 949 950 /* Symbols */ 951 952/* Table of Ada operators and their GNAT-encoded names. Last entry is pair 953 of NULLs. */ 954 955const struct ada_opname_map ada_opname_table[] = { 956 {"Oadd", "\"+\"", BINOP_ADD}, 957 {"Osubtract", "\"-\"", BINOP_SUB}, 958 {"Omultiply", "\"*\"", BINOP_MUL}, 959 {"Odivide", "\"/\"", BINOP_DIV}, 960 {"Omod", "\"mod\"", BINOP_MOD}, 961 {"Orem", "\"rem\"", BINOP_REM}, 962 {"Oexpon", "\"**\"", BINOP_EXP}, 963 {"Olt", "\"<\"", BINOP_LESS}, 964 {"Ole", "\"<=\"", BINOP_LEQ}, 965 {"Ogt", "\">\"", BINOP_GTR}, 966 {"Oge", "\">=\"", BINOP_GEQ}, 967 {"Oeq", "\"=\"", BINOP_EQUAL}, 968 {"One", "\"/=\"", BINOP_NOTEQUAL}, 969 {"Oand", "\"and\"", BINOP_BITWISE_AND}, 970 {"Oor", "\"or\"", BINOP_BITWISE_IOR}, 971 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR}, 972 {"Oconcat", "\"&\"", BINOP_CONCAT}, 973 {"Oabs", "\"abs\"", UNOP_ABS}, 974 {"Onot", "\"not\"", UNOP_LOGICAL_NOT}, 975 {"Oadd", "\"+\"", UNOP_PLUS}, 976 {"Osubtract", "\"-\"", UNOP_NEG}, 977 {NULL, NULL} 978}; 979 980/* The "encoded" form of DECODED, according to GNAT conventions. The 981 result is valid until the next call to ada_encode. If 982 THROW_ERRORS, throw an error if invalid operator name is found. 983 Otherwise, return NULL in that case. */ 984 985static char * 986ada_encode_1 (const char *decoded, bool throw_errors) 987{ 988 static char *encoding_buffer = NULL; 989 static size_t encoding_buffer_size = 0; 990 const char *p; 991 int k; 992 993 if (decoded == NULL) 994 return NULL; 995 996 GROW_VECT (encoding_buffer, encoding_buffer_size, 997 2 * strlen (decoded) + 10); 998 999 k = 0; 1000 for (p = decoded; *p != '\0'; p += 1) 1001 { 1002 if (*p == '.') 1003 { 1004 encoding_buffer[k] = encoding_buffer[k + 1] = '_'; 1005 k += 2; 1006 } 1007 else if (*p == '"') 1008 { 1009 const struct ada_opname_map *mapping; 1010 1011 for (mapping = ada_opname_table; 1012 mapping->encoded != NULL 1013 && !startswith (p, mapping->decoded); mapping += 1) 1014 ; 1015 if (mapping->encoded == NULL) 1016 { 1017 if (throw_errors) 1018 error (_("invalid Ada operator name: %s"), p); 1019 else 1020 return NULL; 1021 } 1022 strcpy (encoding_buffer + k, mapping->encoded); 1023 k += strlen (mapping->encoded); 1024 break; 1025 } 1026 else 1027 { 1028 encoding_buffer[k] = *p; 1029 k += 1; 1030 } 1031 } 1032 1033 encoding_buffer[k] = '\0'; 1034 return encoding_buffer; 1035} 1036 1037/* The "encoded" form of DECODED, according to GNAT conventions. 1038 The result is valid until the next call to ada_encode. */ 1039 1040char * 1041ada_encode (const char *decoded) 1042{ 1043 return ada_encode_1 (decoded, true); 1044} 1045 1046/* Return NAME folded to lower case, or, if surrounded by single 1047 quotes, unfolded, but with the quotes stripped away. Result good 1048 to next call. */ 1049 1050char * 1051ada_fold_name (const char *name) 1052{ 1053 static char *fold_buffer = NULL; 1054 static size_t fold_buffer_size = 0; 1055 1056 int len = strlen (name); 1057 GROW_VECT (fold_buffer, fold_buffer_size, len + 1); 1058 1059 if (name[0] == '\'') 1060 { 1061 strncpy (fold_buffer, name + 1, len - 2); 1062 fold_buffer[len - 2] = '\000'; 1063 } 1064 else 1065 { 1066 int i; 1067 1068 for (i = 0; i <= len; i += 1) 1069 fold_buffer[i] = tolower (name[i]); 1070 } 1071 1072 return fold_buffer; 1073} 1074 1075/* Return nonzero if C is either a digit or a lowercase alphabet character. */ 1076 1077static int 1078is_lower_alphanum (const char c) 1079{ 1080 return (isdigit (c) || (isalpha (c) && islower (c))); 1081} 1082 1083/* ENCODED is the linkage name of a symbol and LEN contains its length. 1084 This function saves in LEN the length of that same symbol name but 1085 without either of these suffixes: 1086 . .{DIGIT}+ 1087 . ${DIGIT}+ 1088 . ___{DIGIT}+ 1089 . __{DIGIT}+. 1090 1091 These are suffixes introduced by the compiler for entities such as 1092 nested subprogram for instance, in order to avoid name clashes. 1093 They do not serve any purpose for the debugger. */ 1094 1095static void 1096ada_remove_trailing_digits (const char *encoded, int *len) 1097{ 1098 if (*len > 1 && isdigit (encoded[*len - 1])) 1099 { 1100 int i = *len - 2; 1101 1102 while (i > 0 && isdigit (encoded[i])) 1103 i--; 1104 if (i >= 0 && encoded[i] == '.') 1105 *len = i; 1106 else if (i >= 0 && encoded[i] == '$') 1107 *len = i; 1108 else if (i >= 2 && startswith (encoded + i - 2, "___")) 1109 *len = i - 2; 1110 else if (i >= 1 && startswith (encoded + i - 1, "__")) 1111 *len = i - 1; 1112 } 1113} 1114 1115/* Remove the suffix introduced by the compiler for protected object 1116 subprograms. */ 1117 1118static void 1119ada_remove_po_subprogram_suffix (const char *encoded, int *len) 1120{ 1121 /* Remove trailing N. */ 1122 1123 /* Protected entry subprograms are broken into two 1124 separate subprograms: The first one is unprotected, and has 1125 a 'N' suffix; the second is the protected version, and has 1126 the 'P' suffix. The second calls the first one after handling 1127 the protection. Since the P subprograms are internally generated, 1128 we leave these names undecoded, giving the user a clue that this 1129 entity is internal. */ 1130 1131 if (*len > 1 1132 && encoded[*len - 1] == 'N' 1133 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2]))) 1134 *len = *len - 1; 1135} 1136 1137/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */ 1138 1139static void 1140ada_remove_Xbn_suffix (const char *encoded, int *len) 1141{ 1142 int i = *len - 1; 1143 1144 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n')) 1145 i--; 1146 1147 if (encoded[i] != 'X') 1148 return; 1149 1150 if (i == 0) 1151 return; 1152 1153 if (isalnum (encoded[i-1])) 1154 *len = i; 1155} 1156 1157/* If ENCODED follows the GNAT entity encoding conventions, then return 1158 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is 1159 replaced by ENCODED. 1160 1161 The resulting string is valid until the next call of ada_decode. 1162 If the string is unchanged by decoding, the original string pointer 1163 is returned. */ 1164 1165const char * 1166ada_decode (const char *encoded) 1167{ 1168 int i, j; 1169 int len0; 1170 const char *p; 1171 char *decoded; 1172 int at_start_name; 1173 static char *decoding_buffer = NULL; 1174 static size_t decoding_buffer_size = 0; 1175 1176 /* With function descriptors on PPC64, the value of a symbol named 1177 ".FN", if it exists, is the entry point of the function "FN". */ 1178 if (encoded[0] == '.') 1179 encoded += 1; 1180 1181 /* The name of the Ada main procedure starts with "_ada_". 1182 This prefix is not part of the decoded name, so skip this part 1183 if we see this prefix. */ 1184 if (startswith (encoded, "_ada_")) 1185 encoded += 5; 1186 1187 /* If the name starts with '_', then it is not a properly encoded 1188 name, so do not attempt to decode it. Similarly, if the name 1189 starts with '<', the name should not be decoded. */ 1190 if (encoded[0] == '_' || encoded[0] == '<') 1191 goto Suppress; 1192 1193 len0 = strlen (encoded); 1194 1195 ada_remove_trailing_digits (encoded, &len0); 1196 ada_remove_po_subprogram_suffix (encoded, &len0); 1197 1198 /* Remove the ___X.* suffix if present. Do not forget to verify that 1199 the suffix is located before the current "end" of ENCODED. We want 1200 to avoid re-matching parts of ENCODED that have previously been 1201 marked as discarded (by decrementing LEN0). */ 1202 p = strstr (encoded, "___"); 1203 if (p != NULL && p - encoded < len0 - 3) 1204 { 1205 if (p[3] == 'X') 1206 len0 = p - encoded; 1207 else 1208 goto Suppress; 1209 } 1210 1211 /* Remove any trailing TKB suffix. It tells us that this symbol 1212 is for the body of a task, but that information does not actually 1213 appear in the decoded name. */ 1214 1215 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB")) 1216 len0 -= 3; 1217 1218 /* Remove any trailing TB suffix. The TB suffix is slightly different 1219 from the TKB suffix because it is used for non-anonymous task 1220 bodies. */ 1221 1222 if (len0 > 2 && startswith (encoded + len0 - 2, "TB")) 1223 len0 -= 2; 1224 1225 /* Remove trailing "B" suffixes. */ 1226 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */ 1227 1228 if (len0 > 1 && startswith (encoded + len0 - 1, "B")) 1229 len0 -= 1; 1230 1231 /* Make decoded big enough for possible expansion by operator name. */ 1232 1233 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1); 1234 decoded = decoding_buffer; 1235 1236 /* Remove trailing __{digit}+ or trailing ${digit}+. */ 1237 1238 if (len0 > 1 && isdigit (encoded[len0 - 1])) 1239 { 1240 i = len0 - 2; 1241 while ((i >= 0 && isdigit (encoded[i])) 1242 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1]))) 1243 i -= 1; 1244 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_') 1245 len0 = i - 1; 1246 else if (encoded[i] == '$') 1247 len0 = i; 1248 } 1249 1250 /* The first few characters that are not alphabetic are not part 1251 of any encoding we use, so we can copy them over verbatim. */ 1252 1253 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1) 1254 decoded[j] = encoded[i]; 1255 1256 at_start_name = 1; 1257 while (i < len0) 1258 { 1259 /* Is this a symbol function? */ 1260 if (at_start_name && encoded[i] == 'O') 1261 { 1262 int k; 1263 1264 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1) 1265 { 1266 int op_len = strlen (ada_opname_table[k].encoded); 1267 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1, 1268 op_len - 1) == 0) 1269 && !isalnum (encoded[i + op_len])) 1270 { 1271 strcpy (decoded + j, ada_opname_table[k].decoded); 1272 at_start_name = 0; 1273 i += op_len; 1274 j += strlen (ada_opname_table[k].decoded); 1275 break; 1276 } 1277 } 1278 if (ada_opname_table[k].encoded != NULL) 1279 continue; 1280 } 1281 at_start_name = 0; 1282 1283 /* Replace "TK__" with "__", which will eventually be translated 1284 into "." (just below). */ 1285 1286 if (i < len0 - 4 && startswith (encoded + i, "TK__")) 1287 i += 2; 1288 1289 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually 1290 be translated into "." (just below). These are internal names 1291 generated for anonymous blocks inside which our symbol is nested. */ 1292 1293 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_' 1294 && encoded [i+2] == 'B' && encoded [i+3] == '_' 1295 && isdigit (encoded [i+4])) 1296 { 1297 int k = i + 5; 1298 1299 while (k < len0 && isdigit (encoded[k])) 1300 k++; /* Skip any extra digit. */ 1301 1302 /* Double-check that the "__B_{DIGITS}+" sequence we found 1303 is indeed followed by "__". */ 1304 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_') 1305 i = k; 1306 } 1307 1308 /* Remove _E{DIGITS}+[sb] */ 1309 1310 /* Just as for protected object subprograms, there are 2 categories 1311 of subprograms created by the compiler for each entry. The first 1312 one implements the actual entry code, and has a suffix following 1313 the convention above; the second one implements the barrier and 1314 uses the same convention as above, except that the 'E' is replaced 1315 by a 'B'. 1316 1317 Just as above, we do not decode the name of barrier functions 1318 to give the user a clue that the code he is debugging has been 1319 internally generated. */ 1320 1321 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E' 1322 && isdigit (encoded[i+2])) 1323 { 1324 int k = i + 3; 1325 1326 while (k < len0 && isdigit (encoded[k])) 1327 k++; 1328 1329 if (k < len0 1330 && (encoded[k] == 'b' || encoded[k] == 's')) 1331 { 1332 k++; 1333 /* Just as an extra precaution, make sure that if this 1334 suffix is followed by anything else, it is a '_'. 1335 Otherwise, we matched this sequence by accident. */ 1336 if (k == len0 1337 || (k < len0 && encoded[k] == '_')) 1338 i = k; 1339 } 1340 } 1341 1342 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by 1343 the GNAT front-end in protected object subprograms. */ 1344 1345 if (i < len0 + 3 1346 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_') 1347 { 1348 /* Backtrack a bit up until we reach either the begining of 1349 the encoded name, or "__". Make sure that we only find 1350 digits or lowercase characters. */ 1351 const char *ptr = encoded + i - 1; 1352 1353 while (ptr >= encoded && is_lower_alphanum (ptr[0])) 1354 ptr--; 1355 if (ptr < encoded 1356 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_')) 1357 i++; 1358 } 1359 1360 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1])) 1361 { 1362 /* This is a X[bn]* sequence not separated from the previous 1363 part of the name with a non-alpha-numeric character (in other 1364 words, immediately following an alpha-numeric character), then 1365 verify that it is placed at the end of the encoded name. If 1366 not, then the encoding is not valid and we should abort the 1367 decoding. Otherwise, just skip it, it is used in body-nested 1368 package names. */ 1369 do 1370 i += 1; 1371 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n')); 1372 if (i < len0) 1373 goto Suppress; 1374 } 1375 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_') 1376 { 1377 /* Replace '__' by '.'. */ 1378 decoded[j] = '.'; 1379 at_start_name = 1; 1380 i += 2; 1381 j += 1; 1382 } 1383 else 1384 { 1385 /* It's a character part of the decoded name, so just copy it 1386 over. */ 1387 decoded[j] = encoded[i]; 1388 i += 1; 1389 j += 1; 1390 } 1391 } 1392 decoded[j] = '\000'; 1393 1394 /* Decoded names should never contain any uppercase character. 1395 Double-check this, and abort the decoding if we find one. */ 1396 1397 for (i = 0; decoded[i] != '\0'; i += 1) 1398 if (isupper (decoded[i]) || decoded[i] == ' ') 1399 goto Suppress; 1400 1401 if (strcmp (decoded, encoded) == 0) 1402 return encoded; 1403 else 1404 return decoded; 1405 1406Suppress: 1407 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3); 1408 decoded = decoding_buffer; 1409 if (encoded[0] == '<') 1410 strcpy (decoded, encoded); 1411 else 1412 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded); 1413 return decoded; 1414 1415} 1416 1417/* Table for keeping permanent unique copies of decoded names. Once 1418 allocated, names in this table are never released. While this is a 1419 storage leak, it should not be significant unless there are massive 1420 changes in the set of decoded names in successive versions of a 1421 symbol table loaded during a single session. */ 1422static struct htab *decoded_names_store; 1423 1424/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it 1425 in the language-specific part of GSYMBOL, if it has not been 1426 previously computed. Tries to save the decoded name in the same 1427 obstack as GSYMBOL, if possible, and otherwise on the heap (so that, 1428 in any case, the decoded symbol has a lifetime at least that of 1429 GSYMBOL). 1430 The GSYMBOL parameter is "mutable" in the C++ sense: logically 1431 const, but nevertheless modified to a semantically equivalent form 1432 when a decoded name is cached in it. */ 1433 1434const char * 1435ada_decode_symbol (const struct general_symbol_info *arg) 1436{ 1437 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg; 1438 const char **resultp = 1439 &gsymbol->language_specific.demangled_name; 1440 1441 if (!gsymbol->ada_mangled) 1442 { 1443 const char *decoded = ada_decode (gsymbol->name); 1444 struct obstack *obstack = gsymbol->language_specific.obstack; 1445 1446 gsymbol->ada_mangled = 1; 1447 1448 if (obstack != NULL) 1449 *resultp 1450 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded)); 1451 else 1452 { 1453 /* Sometimes, we can't find a corresponding objfile, in 1454 which case, we put the result on the heap. Since we only 1455 decode when needed, we hope this usually does not cause a 1456 significant memory leak (FIXME). */ 1457 1458 char **slot = (char **) htab_find_slot (decoded_names_store, 1459 decoded, INSERT); 1460 1461 if (*slot == NULL) 1462 *slot = xstrdup (decoded); 1463 *resultp = *slot; 1464 } 1465 } 1466 1467 return *resultp; 1468} 1469 1470static char * 1471ada_la_decode (const char *encoded, int options) 1472{ 1473 return xstrdup (ada_decode (encoded)); 1474} 1475 1476/* Implement la_sniff_from_mangled_name for Ada. */ 1477 1478static int 1479ada_sniff_from_mangled_name (const char *mangled, char **out) 1480{ 1481 const char *demangled = ada_decode (mangled); 1482 1483 *out = NULL; 1484 1485 if (demangled != mangled && demangled != NULL && demangled[0] != '<') 1486 { 1487 /* Set the gsymbol language to Ada, but still return 0. 1488 Two reasons for that: 1489 1490 1. For Ada, we prefer computing the symbol's decoded name 1491 on the fly rather than pre-compute it, in order to save 1492 memory (Ada projects are typically very large). 1493 1494 2. There are some areas in the definition of the GNAT 1495 encoding where, with a bit of bad luck, we might be able 1496 to decode a non-Ada symbol, generating an incorrect 1497 demangled name (Eg: names ending with "TB" for instance 1498 are identified as task bodies and so stripped from 1499 the decoded name returned). 1500 1501 Returning 1, here, but not setting *DEMANGLED, helps us get a 1502 little bit of the best of both worlds. Because we're last, 1503 we should not affect any of the other languages that were 1504 able to demangle the symbol before us; we get to correctly 1505 tag Ada symbols as such; and even if we incorrectly tagged a 1506 non-Ada symbol, which should be rare, any routing through the 1507 Ada language should be transparent (Ada tries to behave much 1508 like C/C++ with non-Ada symbols). */ 1509 return 1; 1510 } 1511 1512 return 0; 1513} 1514 1515 1516 1517 /* Arrays */ 1518 1519/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure 1520 generated by the GNAT compiler to describe the index type used 1521 for each dimension of an array, check whether it follows the latest 1522 known encoding. If not, fix it up to conform to the latest encoding. 1523 Otherwise, do nothing. This function also does nothing if 1524 INDEX_DESC_TYPE is NULL. 1525 1526 The GNAT encoding used to describle the array index type evolved a bit. 1527 Initially, the information would be provided through the name of each 1528 field of the structure type only, while the type of these fields was 1529 described as unspecified and irrelevant. The debugger was then expected 1530 to perform a global type lookup using the name of that field in order 1531 to get access to the full index type description. Because these global 1532 lookups can be very expensive, the encoding was later enhanced to make 1533 the global lookup unnecessary by defining the field type as being 1534 the full index type description. 1535 1536 The purpose of this routine is to allow us to support older versions 1537 of the compiler by detecting the use of the older encoding, and by 1538 fixing up the INDEX_DESC_TYPE to follow the new one (at this point, 1539 we essentially replace each field's meaningless type by the associated 1540 index subtype). */ 1541 1542void 1543ada_fixup_array_indexes_type (struct type *index_desc_type) 1544{ 1545 int i; 1546 1547 if (index_desc_type == NULL) 1548 return; 1549 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0); 1550 1551 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient 1552 to check one field only, no need to check them all). If not, return 1553 now. 1554 1555 If our INDEX_DESC_TYPE was generated using the older encoding, 1556 the field type should be a meaningless integer type whose name 1557 is not equal to the field name. */ 1558 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL 1559 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)), 1560 TYPE_FIELD_NAME (index_desc_type, 0)) == 0) 1561 return; 1562 1563 /* Fixup each field of INDEX_DESC_TYPE. */ 1564 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++) 1565 { 1566 const char *name = TYPE_FIELD_NAME (index_desc_type, i); 1567 struct type *raw_type = ada_check_typedef (ada_find_any_type (name)); 1568 1569 if (raw_type) 1570 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type; 1571 } 1572} 1573 1574/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */ 1575 1576static const char *bound_name[] = { 1577 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3", 1578 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7" 1579}; 1580 1581/* Maximum number of array dimensions we are prepared to handle. */ 1582 1583#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *))) 1584 1585 1586/* The desc_* routines return primitive portions of array descriptors 1587 (fat pointers). */ 1588 1589/* The descriptor or array type, if any, indicated by TYPE; removes 1590 level of indirection, if needed. */ 1591 1592static struct type * 1593desc_base_type (struct type *type) 1594{ 1595 if (type == NULL) 1596 return NULL; 1597 type = ada_check_typedef (type); 1598 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 1599 type = ada_typedef_target_type (type); 1600 1601 if (type != NULL 1602 && (TYPE_CODE (type) == TYPE_CODE_PTR 1603 || TYPE_CODE (type) == TYPE_CODE_REF)) 1604 return ada_check_typedef (TYPE_TARGET_TYPE (type)); 1605 else 1606 return type; 1607} 1608 1609/* True iff TYPE indicates a "thin" array pointer type. */ 1610 1611static int 1612is_thin_pntr (struct type *type) 1613{ 1614 return 1615 is_suffix (ada_type_name (desc_base_type (type)), "___XUT") 1616 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE"); 1617} 1618 1619/* The descriptor type for thin pointer type TYPE. */ 1620 1621static struct type * 1622thin_descriptor_type (struct type *type) 1623{ 1624 struct type *base_type = desc_base_type (type); 1625 1626 if (base_type == NULL) 1627 return NULL; 1628 if (is_suffix (ada_type_name (base_type), "___XVE")) 1629 return base_type; 1630 else 1631 { 1632 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE"); 1633 1634 if (alt_type == NULL) 1635 return base_type; 1636 else 1637 return alt_type; 1638 } 1639} 1640 1641/* A pointer to the array data for thin-pointer value VAL. */ 1642 1643static struct value * 1644thin_data_pntr (struct value *val) 1645{ 1646 struct type *type = ada_check_typedef (value_type (val)); 1647 struct type *data_type = desc_data_target_type (thin_descriptor_type (type)); 1648 1649 data_type = lookup_pointer_type (data_type); 1650 1651 if (TYPE_CODE (type) == TYPE_CODE_PTR) 1652 return value_cast (data_type, value_copy (val)); 1653 else 1654 return value_from_longest (data_type, value_address (val)); 1655} 1656 1657/* True iff TYPE indicates a "thick" array pointer type. */ 1658 1659static int 1660is_thick_pntr (struct type *type) 1661{ 1662 type = desc_base_type (type); 1663 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT 1664 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL); 1665} 1666 1667/* If TYPE is the type of an array descriptor (fat or thin pointer) or a 1668 pointer to one, the type of its bounds data; otherwise, NULL. */ 1669 1670static struct type * 1671desc_bounds_type (struct type *type) 1672{ 1673 struct type *r; 1674 1675 type = desc_base_type (type); 1676 1677 if (type == NULL) 1678 return NULL; 1679 else if (is_thin_pntr (type)) 1680 { 1681 type = thin_descriptor_type (type); 1682 if (type == NULL) 1683 return NULL; 1684 r = lookup_struct_elt_type (type, "BOUNDS", 1); 1685 if (r != NULL) 1686 return ada_check_typedef (r); 1687 } 1688 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 1689 { 1690 r = lookup_struct_elt_type (type, "P_BOUNDS", 1); 1691 if (r != NULL) 1692 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r))); 1693 } 1694 return NULL; 1695} 1696 1697/* If ARR is an array descriptor (fat or thin pointer), or pointer to 1698 one, a pointer to its bounds data. Otherwise NULL. */ 1699 1700static struct value * 1701desc_bounds (struct value *arr) 1702{ 1703 struct type *type = ada_check_typedef (value_type (arr)); 1704 1705 if (is_thin_pntr (type)) 1706 { 1707 struct type *bounds_type = 1708 desc_bounds_type (thin_descriptor_type (type)); 1709 LONGEST addr; 1710 1711 if (bounds_type == NULL) 1712 error (_("Bad GNAT array descriptor")); 1713 1714 /* NOTE: The following calculation is not really kosher, but 1715 since desc_type is an XVE-encoded type (and shouldn't be), 1716 the correct calculation is a real pain. FIXME (and fix GCC). */ 1717 if (TYPE_CODE (type) == TYPE_CODE_PTR) 1718 addr = value_as_long (arr); 1719 else 1720 addr = value_address (arr); 1721 1722 return 1723 value_from_longest (lookup_pointer_type (bounds_type), 1724 addr - TYPE_LENGTH (bounds_type)); 1725 } 1726 1727 else if (is_thick_pntr (type)) 1728 { 1729 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL, 1730 _("Bad GNAT array descriptor")); 1731 struct type *p_bounds_type = value_type (p_bounds); 1732 1733 if (p_bounds_type 1734 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR) 1735 { 1736 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type); 1737 1738 if (TYPE_STUB (target_type)) 1739 p_bounds = value_cast (lookup_pointer_type 1740 (ada_check_typedef (target_type)), 1741 p_bounds); 1742 } 1743 else 1744 error (_("Bad GNAT array descriptor")); 1745 1746 return p_bounds; 1747 } 1748 else 1749 return NULL; 1750} 1751 1752/* If TYPE is the type of an array-descriptor (fat pointer), the bit 1753 position of the field containing the address of the bounds data. */ 1754 1755static int 1756fat_pntr_bounds_bitpos (struct type *type) 1757{ 1758 return TYPE_FIELD_BITPOS (desc_base_type (type), 1); 1759} 1760 1761/* If TYPE is the type of an array-descriptor (fat pointer), the bit 1762 size of the field containing the address of the bounds data. */ 1763 1764static int 1765fat_pntr_bounds_bitsize (struct type *type) 1766{ 1767 type = desc_base_type (type); 1768 1769 if (TYPE_FIELD_BITSIZE (type, 1) > 0) 1770 return TYPE_FIELD_BITSIZE (type, 1); 1771 else 1772 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1))); 1773} 1774 1775/* If TYPE is the type of an array descriptor (fat or thin pointer) or a 1776 pointer to one, the type of its array data (a array-with-no-bounds type); 1777 otherwise, NULL. Use ada_type_of_array to get an array type with bounds 1778 data. */ 1779 1780static struct type * 1781desc_data_target_type (struct type *type) 1782{ 1783 type = desc_base_type (type); 1784 1785 /* NOTE: The following is bogus; see comment in desc_bounds. */ 1786 if (is_thin_pntr (type)) 1787 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)); 1788 else if (is_thick_pntr (type)) 1789 { 1790 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1); 1791 1792 if (data_type 1793 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR) 1794 return ada_check_typedef (TYPE_TARGET_TYPE (data_type)); 1795 } 1796 1797 return NULL; 1798} 1799 1800/* If ARR is an array descriptor (fat or thin pointer), a pointer to 1801 its array data. */ 1802 1803static struct value * 1804desc_data (struct value *arr) 1805{ 1806 struct type *type = value_type (arr); 1807 1808 if (is_thin_pntr (type)) 1809 return thin_data_pntr (arr); 1810 else if (is_thick_pntr (type)) 1811 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL, 1812 _("Bad GNAT array descriptor")); 1813 else 1814 return NULL; 1815} 1816 1817 1818/* If TYPE is the type of an array-descriptor (fat pointer), the bit 1819 position of the field containing the address of the data. */ 1820 1821static int 1822fat_pntr_data_bitpos (struct type *type) 1823{ 1824 return TYPE_FIELD_BITPOS (desc_base_type (type), 0); 1825} 1826 1827/* If TYPE is the type of an array-descriptor (fat pointer), the bit 1828 size of the field containing the address of the data. */ 1829 1830static int 1831fat_pntr_data_bitsize (struct type *type) 1832{ 1833 type = desc_base_type (type); 1834 1835 if (TYPE_FIELD_BITSIZE (type, 0) > 0) 1836 return TYPE_FIELD_BITSIZE (type, 0); 1837 else 1838 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0)); 1839} 1840 1841/* If BOUNDS is an array-bounds structure (or pointer to one), return 1842 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1843 bound, if WHICH is 1. The first bound is I=1. */ 1844 1845static struct value * 1846desc_one_bound (struct value *bounds, int i, int which) 1847{ 1848 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL, 1849 _("Bad GNAT array descriptor bounds")); 1850} 1851 1852/* If BOUNDS is an array-bounds structure type, return the bit position 1853 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1854 bound, if WHICH is 1. The first bound is I=1. */ 1855 1856static int 1857desc_bound_bitpos (struct type *type, int i, int which) 1858{ 1859 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2); 1860} 1861 1862/* If BOUNDS is an array-bounds structure type, return the bit field size 1863 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1864 bound, if WHICH is 1. The first bound is I=1. */ 1865 1866static int 1867desc_bound_bitsize (struct type *type, int i, int which) 1868{ 1869 type = desc_base_type (type); 1870 1871 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0) 1872 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2); 1873 else 1874 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2)); 1875} 1876 1877/* If TYPE is the type of an array-bounds structure, the type of its 1878 Ith bound (numbering from 1). Otherwise, NULL. */ 1879 1880static struct type * 1881desc_index_type (struct type *type, int i) 1882{ 1883 type = desc_base_type (type); 1884 1885 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 1886 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1); 1887 else 1888 return NULL; 1889} 1890 1891/* The number of index positions in the array-bounds type TYPE. 1892 Return 0 if TYPE is NULL. */ 1893 1894static int 1895desc_arity (struct type *type) 1896{ 1897 type = desc_base_type (type); 1898 1899 if (type != NULL) 1900 return TYPE_NFIELDS (type) / 2; 1901 return 0; 1902} 1903 1904/* Non-zero iff TYPE is a simple array type (not a pointer to one) or 1905 an array descriptor type (representing an unconstrained array 1906 type). */ 1907 1908static int 1909ada_is_direct_array_type (struct type *type) 1910{ 1911 if (type == NULL) 1912 return 0; 1913 type = ada_check_typedef (type); 1914 return (TYPE_CODE (type) == TYPE_CODE_ARRAY 1915 || ada_is_array_descriptor_type (type)); 1916} 1917 1918/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer 1919 * to one. */ 1920 1921static int 1922ada_is_array_type (struct type *type) 1923{ 1924 while (type != NULL 1925 && (TYPE_CODE (type) == TYPE_CODE_PTR 1926 || TYPE_CODE (type) == TYPE_CODE_REF)) 1927 type = TYPE_TARGET_TYPE (type); 1928 return ada_is_direct_array_type (type); 1929} 1930 1931/* Non-zero iff TYPE is a simple array type or pointer to one. */ 1932 1933int 1934ada_is_simple_array_type (struct type *type) 1935{ 1936 if (type == NULL) 1937 return 0; 1938 type = ada_check_typedef (type); 1939 return (TYPE_CODE (type) == TYPE_CODE_ARRAY 1940 || (TYPE_CODE (type) == TYPE_CODE_PTR 1941 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))) 1942 == TYPE_CODE_ARRAY)); 1943} 1944 1945/* Non-zero iff TYPE belongs to a GNAT array descriptor. */ 1946 1947int 1948ada_is_array_descriptor_type (struct type *type) 1949{ 1950 struct type *data_type = desc_data_target_type (type); 1951 1952 if (type == NULL) 1953 return 0; 1954 type = ada_check_typedef (type); 1955 return (data_type != NULL 1956 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY 1957 && desc_arity (desc_bounds_type (type)) > 0); 1958} 1959 1960/* Non-zero iff type is a partially mal-formed GNAT array 1961 descriptor. FIXME: This is to compensate for some problems with 1962 debugging output from GNAT. Re-examine periodically to see if it 1963 is still needed. */ 1964 1965int 1966ada_is_bogus_array_descriptor (struct type *type) 1967{ 1968 return 1969 type != NULL 1970 && TYPE_CODE (type) == TYPE_CODE_STRUCT 1971 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL 1972 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL) 1973 && !ada_is_array_descriptor_type (type); 1974} 1975 1976 1977/* If ARR has a record type in the form of a standard GNAT array descriptor, 1978 (fat pointer) returns the type of the array data described---specifically, 1979 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled 1980 in from the descriptor; otherwise, they are left unspecified. If 1981 the ARR denotes a null array descriptor and BOUNDS is non-zero, 1982 returns NULL. The result is simply the type of ARR if ARR is not 1983 a descriptor. */ 1984struct type * 1985ada_type_of_array (struct value *arr, int bounds) 1986{ 1987 if (ada_is_constrained_packed_array_type (value_type (arr))) 1988 return decode_constrained_packed_array_type (value_type (arr)); 1989 1990 if (!ada_is_array_descriptor_type (value_type (arr))) 1991 return value_type (arr); 1992 1993 if (!bounds) 1994 { 1995 struct type *array_type = 1996 ada_check_typedef (desc_data_target_type (value_type (arr))); 1997 1998 if (ada_is_unconstrained_packed_array_type (value_type (arr))) 1999 TYPE_FIELD_BITSIZE (array_type, 0) = 2000 decode_packed_array_bitsize (value_type (arr)); 2001 2002 return array_type; 2003 } 2004 else 2005 { 2006 struct type *elt_type; 2007 int arity; 2008 struct value *descriptor; 2009 2010 elt_type = ada_array_element_type (value_type (arr), -1); 2011 arity = ada_array_arity (value_type (arr)); 2012 2013 if (elt_type == NULL || arity == 0) 2014 return ada_check_typedef (value_type (arr)); 2015 2016 descriptor = desc_bounds (arr); 2017 if (value_as_long (descriptor) == 0) 2018 return NULL; 2019 while (arity > 0) 2020 { 2021 struct type *range_type = alloc_type_copy (value_type (arr)); 2022 struct type *array_type = alloc_type_copy (value_type (arr)); 2023 struct value *low = desc_one_bound (descriptor, arity, 0); 2024 struct value *high = desc_one_bound (descriptor, arity, 1); 2025 2026 arity -= 1; 2027 create_static_range_type (range_type, value_type (low), 2028 longest_to_int (value_as_long (low)), 2029 longest_to_int (value_as_long (high))); 2030 elt_type = create_array_type (array_type, elt_type, range_type); 2031 2032 if (ada_is_unconstrained_packed_array_type (value_type (arr))) 2033 { 2034 /* We need to store the element packed bitsize, as well as 2035 recompute the array size, because it was previously 2036 computed based on the unpacked element size. */ 2037 LONGEST lo = value_as_long (low); 2038 LONGEST hi = value_as_long (high); 2039 2040 TYPE_FIELD_BITSIZE (elt_type, 0) = 2041 decode_packed_array_bitsize (value_type (arr)); 2042 /* If the array has no element, then the size is already 2043 zero, and does not need to be recomputed. */ 2044 if (lo < hi) 2045 { 2046 int array_bitsize = 2047 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0); 2048 2049 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8; 2050 } 2051 } 2052 } 2053 2054 return lookup_pointer_type (elt_type); 2055 } 2056} 2057 2058/* If ARR does not represent an array, returns ARR unchanged. 2059 Otherwise, returns either a standard GDB array with bounds set 2060 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard 2061 GDB array. Returns NULL if ARR is a null fat pointer. */ 2062 2063struct value * 2064ada_coerce_to_simple_array_ptr (struct value *arr) 2065{ 2066 if (ada_is_array_descriptor_type (value_type (arr))) 2067 { 2068 struct type *arrType = ada_type_of_array (arr, 1); 2069 2070 if (arrType == NULL) 2071 return NULL; 2072 return value_cast (arrType, value_copy (desc_data (arr))); 2073 } 2074 else if (ada_is_constrained_packed_array_type (value_type (arr))) 2075 return decode_constrained_packed_array (arr); 2076 else 2077 return arr; 2078} 2079 2080/* If ARR does not represent an array, returns ARR unchanged. 2081 Otherwise, returns a standard GDB array describing ARR (which may 2082 be ARR itself if it already is in the proper form). */ 2083 2084struct value * 2085ada_coerce_to_simple_array (struct value *arr) 2086{ 2087 if (ada_is_array_descriptor_type (value_type (arr))) 2088 { 2089 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr); 2090 2091 if (arrVal == NULL) 2092 error (_("Bounds unavailable for null array pointer.")); 2093 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal))); 2094 return value_ind (arrVal); 2095 } 2096 else if (ada_is_constrained_packed_array_type (value_type (arr))) 2097 return decode_constrained_packed_array (arr); 2098 else 2099 return arr; 2100} 2101 2102/* If TYPE represents a GNAT array type, return it translated to an 2103 ordinary GDB array type (possibly with BITSIZE fields indicating 2104 packing). For other types, is the identity. */ 2105 2106struct type * 2107ada_coerce_to_simple_array_type (struct type *type) 2108{ 2109 if (ada_is_constrained_packed_array_type (type)) 2110 return decode_constrained_packed_array_type (type); 2111 2112 if (ada_is_array_descriptor_type (type)) 2113 return ada_check_typedef (desc_data_target_type (type)); 2114 2115 return type; 2116} 2117 2118/* Non-zero iff TYPE represents a standard GNAT packed-array type. */ 2119 2120static int 2121ada_is_packed_array_type (struct type *type) 2122{ 2123 if (type == NULL) 2124 return 0; 2125 type = desc_base_type (type); 2126 type = ada_check_typedef (type); 2127 return 2128 ada_type_name (type) != NULL 2129 && strstr (ada_type_name (type), "___XP") != NULL; 2130} 2131 2132/* Non-zero iff TYPE represents a standard GNAT constrained 2133 packed-array type. */ 2134 2135int 2136ada_is_constrained_packed_array_type (struct type *type) 2137{ 2138 return ada_is_packed_array_type (type) 2139 && !ada_is_array_descriptor_type (type); 2140} 2141 2142/* Non-zero iff TYPE represents an array descriptor for a 2143 unconstrained packed-array type. */ 2144 2145static int 2146ada_is_unconstrained_packed_array_type (struct type *type) 2147{ 2148 return ada_is_packed_array_type (type) 2149 && ada_is_array_descriptor_type (type); 2150} 2151 2152/* Given that TYPE encodes a packed array type (constrained or unconstrained), 2153 return the size of its elements in bits. */ 2154 2155static long 2156decode_packed_array_bitsize (struct type *type) 2157{ 2158 const char *raw_name; 2159 const char *tail; 2160 long bits; 2161 2162 /* Access to arrays implemented as fat pointers are encoded as a typedef 2163 of the fat pointer type. We need the name of the fat pointer type 2164 to do the decoding, so strip the typedef layer. */ 2165 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 2166 type = ada_typedef_target_type (type); 2167 2168 raw_name = ada_type_name (ada_check_typedef (type)); 2169 if (!raw_name) 2170 raw_name = ada_type_name (desc_base_type (type)); 2171 2172 if (!raw_name) 2173 return 0; 2174 2175 tail = strstr (raw_name, "___XP"); 2176 gdb_assert (tail != NULL); 2177 2178 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1) 2179 { 2180 lim_warning 2181 (_("could not understand bit size information on packed array")); 2182 return 0; 2183 } 2184 2185 return bits; 2186} 2187 2188/* Given that TYPE is a standard GDB array type with all bounds filled 2189 in, and that the element size of its ultimate scalar constituents 2190 (that is, either its elements, or, if it is an array of arrays, its 2191 elements' elements, etc.) is *ELT_BITS, return an identical type, 2192 but with the bit sizes of its elements (and those of any 2193 constituent arrays) recorded in the BITSIZE components of its 2194 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size 2195 in bits. 2196 2197 Note that, for arrays whose index type has an XA encoding where 2198 a bound references a record discriminant, getting that discriminant, 2199 and therefore the actual value of that bound, is not possible 2200 because none of the given parameters gives us access to the record. 2201 This function assumes that it is OK in the context where it is being 2202 used to return an array whose bounds are still dynamic and where 2203 the length is arbitrary. */ 2204 2205static struct type * 2206constrained_packed_array_type (struct type *type, long *elt_bits) 2207{ 2208 struct type *new_elt_type; 2209 struct type *new_type; 2210 struct type *index_type_desc; 2211 struct type *index_type; 2212 LONGEST low_bound, high_bound; 2213 2214 type = ada_check_typedef (type); 2215 if (TYPE_CODE (type) != TYPE_CODE_ARRAY) 2216 return type; 2217 2218 index_type_desc = ada_find_parallel_type (type, "___XA"); 2219 if (index_type_desc) 2220 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0), 2221 NULL); 2222 else 2223 index_type = TYPE_INDEX_TYPE (type); 2224 2225 new_type = alloc_type_copy (type); 2226 new_elt_type = 2227 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)), 2228 elt_bits); 2229 create_array_type (new_type, new_elt_type, index_type); 2230 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits; 2231 TYPE_NAME (new_type) = ada_type_name (type); 2232 2233 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE 2234 && is_dynamic_type (check_typedef (index_type))) 2235 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0) 2236 low_bound = high_bound = 0; 2237 if (high_bound < low_bound) 2238 *elt_bits = TYPE_LENGTH (new_type) = 0; 2239 else 2240 { 2241 *elt_bits *= (high_bound - low_bound + 1); 2242 TYPE_LENGTH (new_type) = 2243 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT; 2244 } 2245 2246 TYPE_FIXED_INSTANCE (new_type) = 1; 2247 return new_type; 2248} 2249 2250/* The array type encoded by TYPE, where 2251 ada_is_constrained_packed_array_type (TYPE). */ 2252 2253static struct type * 2254decode_constrained_packed_array_type (struct type *type) 2255{ 2256 const char *raw_name = ada_type_name (ada_check_typedef (type)); 2257 char *name; 2258 const char *tail; 2259 struct type *shadow_type; 2260 long bits; 2261 2262 if (!raw_name) 2263 raw_name = ada_type_name (desc_base_type (type)); 2264 2265 if (!raw_name) 2266 return NULL; 2267 2268 name = (char *) alloca (strlen (raw_name) + 1); 2269 tail = strstr (raw_name, "___XP"); 2270 type = desc_base_type (type); 2271 2272 memcpy (name, raw_name, tail - raw_name); 2273 name[tail - raw_name] = '\000'; 2274 2275 shadow_type = ada_find_parallel_type_with_name (type, name); 2276 2277 if (shadow_type == NULL) 2278 { 2279 lim_warning (_("could not find bounds information on packed array")); 2280 return NULL; 2281 } 2282 shadow_type = check_typedef (shadow_type); 2283 2284 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY) 2285 { 2286 lim_warning (_("could not understand bounds " 2287 "information on packed array")); 2288 return NULL; 2289 } 2290 2291 bits = decode_packed_array_bitsize (type); 2292 return constrained_packed_array_type (shadow_type, &bits); 2293} 2294 2295/* Given that ARR is a struct value *indicating a GNAT constrained packed 2296 array, returns a simple array that denotes that array. Its type is a 2297 standard GDB array type except that the BITSIZEs of the array 2298 target types are set to the number of bits in each element, and the 2299 type length is set appropriately. */ 2300 2301static struct value * 2302decode_constrained_packed_array (struct value *arr) 2303{ 2304 struct type *type; 2305 2306 /* If our value is a pointer, then dereference it. Likewise if 2307 the value is a reference. Make sure that this operation does not 2308 cause the target type to be fixed, as this would indirectly cause 2309 this array to be decoded. The rest of the routine assumes that 2310 the array hasn't been decoded yet, so we use the basic "coerce_ref" 2311 and "value_ind" routines to perform the dereferencing, as opposed 2312 to using "ada_coerce_ref" or "ada_value_ind". */ 2313 arr = coerce_ref (arr); 2314 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR) 2315 arr = value_ind (arr); 2316 2317 type = decode_constrained_packed_array_type (value_type (arr)); 2318 if (type == NULL) 2319 { 2320 error (_("can't unpack array")); 2321 return NULL; 2322 } 2323 2324 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr))) 2325 && ada_is_modular_type (value_type (arr))) 2326 { 2327 /* This is a (right-justified) modular type representing a packed 2328 array with no wrapper. In order to interpret the value through 2329 the (left-justified) packed array type we just built, we must 2330 first left-justify it. */ 2331 int bit_size, bit_pos; 2332 ULONGEST mod; 2333 2334 mod = ada_modulus (value_type (arr)) - 1; 2335 bit_size = 0; 2336 while (mod > 0) 2337 { 2338 bit_size += 1; 2339 mod >>= 1; 2340 } 2341 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size; 2342 arr = ada_value_primitive_packed_val (arr, NULL, 2343 bit_pos / HOST_CHAR_BIT, 2344 bit_pos % HOST_CHAR_BIT, 2345 bit_size, 2346 type); 2347 } 2348 2349 return coerce_unspec_val_to_type (arr, type); 2350} 2351 2352 2353/* The value of the element of packed array ARR at the ARITY indices 2354 given in IND. ARR must be a simple array. */ 2355 2356static struct value * 2357value_subscript_packed (struct value *arr, int arity, struct value **ind) 2358{ 2359 int i; 2360 int bits, elt_off, bit_off; 2361 long elt_total_bit_offset; 2362 struct type *elt_type; 2363 struct value *v; 2364 2365 bits = 0; 2366 elt_total_bit_offset = 0; 2367 elt_type = ada_check_typedef (value_type (arr)); 2368 for (i = 0; i < arity; i += 1) 2369 { 2370 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY 2371 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0) 2372 error 2373 (_("attempt to do packed indexing of " 2374 "something other than a packed array")); 2375 else 2376 { 2377 struct type *range_type = TYPE_INDEX_TYPE (elt_type); 2378 LONGEST lowerbound, upperbound; 2379 LONGEST idx; 2380 2381 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0) 2382 { 2383 lim_warning (_("don't know bounds of array")); 2384 lowerbound = upperbound = 0; 2385 } 2386 2387 idx = pos_atr (ind[i]); 2388 if (idx < lowerbound || idx > upperbound) 2389 lim_warning (_("packed array index %ld out of bounds"), 2390 (long) idx); 2391 bits = TYPE_FIELD_BITSIZE (elt_type, 0); 2392 elt_total_bit_offset += (idx - lowerbound) * bits; 2393 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type)); 2394 } 2395 } 2396 elt_off = elt_total_bit_offset / HOST_CHAR_BIT; 2397 bit_off = elt_total_bit_offset % HOST_CHAR_BIT; 2398 2399 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off, 2400 bits, elt_type); 2401 return v; 2402} 2403 2404/* Non-zero iff TYPE includes negative integer values. */ 2405 2406static int 2407has_negatives (struct type *type) 2408{ 2409 switch (TYPE_CODE (type)) 2410 { 2411 default: 2412 return 0; 2413 case TYPE_CODE_INT: 2414 return !TYPE_UNSIGNED (type); 2415 case TYPE_CODE_RANGE: 2416 return TYPE_LOW_BOUND (type) < 0; 2417 } 2418} 2419 2420/* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET, 2421 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of 2422 the unpacked buffer. 2423 2424 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large 2425 enough to contain at least BIT_OFFSET bits. If not, an error is raised. 2426 2427 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode, 2428 zero otherwise. 2429 2430 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type. 2431 2432 IS_SCALAR is nonzero if the data corresponds to a signed type. */ 2433 2434static void 2435ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size, 2436 gdb_byte *unpacked, int unpacked_len, 2437 int is_big_endian, int is_signed_type, 2438 int is_scalar) 2439{ 2440 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8; 2441 int src_idx; /* Index into the source area */ 2442 int src_bytes_left; /* Number of source bytes left to process. */ 2443 int srcBitsLeft; /* Number of source bits left to move */ 2444 int unusedLS; /* Number of bits in next significant 2445 byte of source that are unused */ 2446 2447 int unpacked_idx; /* Index into the unpacked buffer */ 2448 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */ 2449 2450 unsigned long accum; /* Staging area for bits being transferred */ 2451 int accumSize; /* Number of meaningful bits in accum */ 2452 unsigned char sign; 2453 2454 /* Transmit bytes from least to most significant; delta is the direction 2455 the indices move. */ 2456 int delta = is_big_endian ? -1 : 1; 2457 2458 /* Make sure that unpacked is large enough to receive the BIT_SIZE 2459 bits from SRC. .*/ 2460 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len) 2461 error (_("Cannot unpack %d bits into buffer of %d bytes"), 2462 bit_size, unpacked_len); 2463 2464 srcBitsLeft = bit_size; 2465 src_bytes_left = src_len; 2466 unpacked_bytes_left = unpacked_len; 2467 sign = 0; 2468 2469 if (is_big_endian) 2470 { 2471 src_idx = src_len - 1; 2472 if (is_signed_type 2473 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1)))) 2474 sign = ~0; 2475 2476 unusedLS = 2477 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT) 2478 % HOST_CHAR_BIT; 2479 2480 if (is_scalar) 2481 { 2482 accumSize = 0; 2483 unpacked_idx = unpacked_len - 1; 2484 } 2485 else 2486 { 2487 /* Non-scalar values must be aligned at a byte boundary... */ 2488 accumSize = 2489 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT; 2490 /* ... And are placed at the beginning (most-significant) bytes 2491 of the target. */ 2492 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1; 2493 unpacked_bytes_left = unpacked_idx + 1; 2494 } 2495 } 2496 else 2497 { 2498 int sign_bit_offset = (bit_size + bit_offset - 1) % 8; 2499 2500 src_idx = unpacked_idx = 0; 2501 unusedLS = bit_offset; 2502 accumSize = 0; 2503 2504 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset))) 2505 sign = ~0; 2506 } 2507 2508 accum = 0; 2509 while (src_bytes_left > 0) 2510 { 2511 /* Mask for removing bits of the next source byte that are not 2512 part of the value. */ 2513 unsigned int unusedMSMask = 2514 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) - 2515 1; 2516 /* Sign-extend bits for this byte. */ 2517 unsigned int signMask = sign & ~unusedMSMask; 2518 2519 accum |= 2520 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize; 2521 accumSize += HOST_CHAR_BIT - unusedLS; 2522 if (accumSize >= HOST_CHAR_BIT) 2523 { 2524 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT); 2525 accumSize -= HOST_CHAR_BIT; 2526 accum >>= HOST_CHAR_BIT; 2527 unpacked_bytes_left -= 1; 2528 unpacked_idx += delta; 2529 } 2530 srcBitsLeft -= HOST_CHAR_BIT - unusedLS; 2531 unusedLS = 0; 2532 src_bytes_left -= 1; 2533 src_idx += delta; 2534 } 2535 while (unpacked_bytes_left > 0) 2536 { 2537 accum |= sign << accumSize; 2538 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT); 2539 accumSize -= HOST_CHAR_BIT; 2540 if (accumSize < 0) 2541 accumSize = 0; 2542 accum >>= HOST_CHAR_BIT; 2543 unpacked_bytes_left -= 1; 2544 unpacked_idx += delta; 2545 } 2546} 2547 2548/* Create a new value of type TYPE from the contents of OBJ starting 2549 at byte OFFSET, and bit offset BIT_OFFSET within that byte, 2550 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then 2551 assigning through the result will set the field fetched from. 2552 VALADDR is ignored unless OBJ is NULL, in which case, 2553 VALADDR+OFFSET must address the start of storage containing the 2554 packed value. The value returned in this case is never an lval. 2555 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */ 2556 2557struct value * 2558ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr, 2559 long offset, int bit_offset, int bit_size, 2560 struct type *type) 2561{ 2562 struct value *v; 2563 const gdb_byte *src; /* First byte containing data to unpack */ 2564 gdb_byte *unpacked; 2565 const int is_scalar = is_scalar_type (type); 2566 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type)); 2567 gdb::byte_vector staging; 2568 2569 type = ada_check_typedef (type); 2570 2571 if (obj == NULL) 2572 src = valaddr + offset; 2573 else 2574 src = value_contents (obj) + offset; 2575 2576 if (is_dynamic_type (type)) 2577 { 2578 /* The length of TYPE might by dynamic, so we need to resolve 2579 TYPE in order to know its actual size, which we then use 2580 to create the contents buffer of the value we return. 2581 The difficulty is that the data containing our object is 2582 packed, and therefore maybe not at a byte boundary. So, what 2583 we do, is unpack the data into a byte-aligned buffer, and then 2584 use that buffer as our object's value for resolving the type. */ 2585 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT; 2586 staging.resize (staging_len); 2587 2588 ada_unpack_from_contents (src, bit_offset, bit_size, 2589 staging.data (), staging.size (), 2590 is_big_endian, has_negatives (type), 2591 is_scalar); 2592 type = resolve_dynamic_type (type, staging.data (), 0); 2593 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT) 2594 { 2595 /* This happens when the length of the object is dynamic, 2596 and is actually smaller than the space reserved for it. 2597 For instance, in an array of variant records, the bit_size 2598 we're given is the array stride, which is constant and 2599 normally equal to the maximum size of its element. 2600 But, in reality, each element only actually spans a portion 2601 of that stride. */ 2602 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT; 2603 } 2604 } 2605 2606 if (obj == NULL) 2607 { 2608 v = allocate_value (type); 2609 src = valaddr + offset; 2610 } 2611 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj)) 2612 { 2613 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8; 2614 gdb_byte *buf; 2615 2616 v = value_at (type, value_address (obj) + offset); 2617 buf = (gdb_byte *) alloca (src_len); 2618 read_memory (value_address (v), buf, src_len); 2619 src = buf; 2620 } 2621 else 2622 { 2623 v = allocate_value (type); 2624 src = value_contents (obj) + offset; 2625 } 2626 2627 if (obj != NULL) 2628 { 2629 long new_offset = offset; 2630 2631 set_value_component_location (v, obj); 2632 set_value_bitpos (v, bit_offset + value_bitpos (obj)); 2633 set_value_bitsize (v, bit_size); 2634 if (value_bitpos (v) >= HOST_CHAR_BIT) 2635 { 2636 ++new_offset; 2637 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT); 2638 } 2639 set_value_offset (v, new_offset); 2640 2641 /* Also set the parent value. This is needed when trying to 2642 assign a new value (in inferior memory). */ 2643 set_value_parent (v, obj); 2644 } 2645 else 2646 set_value_bitsize (v, bit_size); 2647 unpacked = value_contents_writeable (v); 2648 2649 if (bit_size == 0) 2650 { 2651 memset (unpacked, 0, TYPE_LENGTH (type)); 2652 return v; 2653 } 2654 2655 if (staging.size () == TYPE_LENGTH (type)) 2656 { 2657 /* Small short-cut: If we've unpacked the data into a buffer 2658 of the same size as TYPE's length, then we can reuse that, 2659 instead of doing the unpacking again. */ 2660 memcpy (unpacked, staging.data (), staging.size ()); 2661 } 2662 else 2663 ada_unpack_from_contents (src, bit_offset, bit_size, 2664 unpacked, TYPE_LENGTH (type), 2665 is_big_endian, has_negatives (type), is_scalar); 2666 2667 return v; 2668} 2669 2670/* Store the contents of FROMVAL into the location of TOVAL. 2671 Return a new value with the location of TOVAL and contents of 2672 FROMVAL. Handles assignment into packed fields that have 2673 floating-point or non-scalar types. */ 2674 2675static struct value * 2676ada_value_assign (struct value *toval, struct value *fromval) 2677{ 2678 struct type *type = value_type (toval); 2679 int bits = value_bitsize (toval); 2680 2681 toval = ada_coerce_ref (toval); 2682 fromval = ada_coerce_ref (fromval); 2683 2684 if (ada_is_direct_array_type (value_type (toval))) 2685 toval = ada_coerce_to_simple_array (toval); 2686 if (ada_is_direct_array_type (value_type (fromval))) 2687 fromval = ada_coerce_to_simple_array (fromval); 2688 2689 if (!deprecated_value_modifiable (toval)) 2690 error (_("Left operand of assignment is not a modifiable lvalue.")); 2691 2692 if (VALUE_LVAL (toval) == lval_memory 2693 && bits > 0 2694 && (TYPE_CODE (type) == TYPE_CODE_FLT 2695 || TYPE_CODE (type) == TYPE_CODE_STRUCT)) 2696 { 2697 int len = (value_bitpos (toval) 2698 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT; 2699 int from_size; 2700 gdb_byte *buffer = (gdb_byte *) alloca (len); 2701 struct value *val; 2702 CORE_ADDR to_addr = value_address (toval); 2703 2704 if (TYPE_CODE (type) == TYPE_CODE_FLT) 2705 fromval = value_cast (type, fromval); 2706 2707 read_memory (to_addr, buffer, len); 2708 from_size = value_bitsize (fromval); 2709 if (from_size == 0) 2710 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT; 2711 if (gdbarch_bits_big_endian (get_type_arch (type))) 2712 copy_bitwise (buffer, value_bitpos (toval), 2713 value_contents (fromval), from_size - bits, bits, 1); 2714 else 2715 copy_bitwise (buffer, value_bitpos (toval), 2716 value_contents (fromval), 0, bits, 0); 2717 write_memory_with_notification (to_addr, buffer, len); 2718 2719 val = value_copy (toval); 2720 memcpy (value_contents_raw (val), value_contents (fromval), 2721 TYPE_LENGTH (type)); 2722 deprecated_set_value_type (val, type); 2723 2724 return val; 2725 } 2726 2727 return value_assign (toval, fromval); 2728} 2729 2730 2731/* Given that COMPONENT is a memory lvalue that is part of the lvalue 2732 CONTAINER, assign the contents of VAL to COMPONENTS's place in 2733 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not 2734 COMPONENT, and not the inferior's memory. The current contents 2735 of COMPONENT are ignored. 2736 2737 Although not part of the initial design, this function also works 2738 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER 2739 had a null address, and COMPONENT had an address which is equal to 2740 its offset inside CONTAINER. */ 2741 2742static void 2743value_assign_to_component (struct value *container, struct value *component, 2744 struct value *val) 2745{ 2746 LONGEST offset_in_container = 2747 (LONGEST) (value_address (component) - value_address (container)); 2748 int bit_offset_in_container = 2749 value_bitpos (component) - value_bitpos (container); 2750 int bits; 2751 2752 val = value_cast (value_type (component), val); 2753 2754 if (value_bitsize (component) == 0) 2755 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component)); 2756 else 2757 bits = value_bitsize (component); 2758 2759 if (gdbarch_bits_big_endian (get_type_arch (value_type (container)))) 2760 { 2761 int src_offset; 2762 2763 if (is_scalar_type (check_typedef (value_type (component)))) 2764 src_offset 2765 = TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits; 2766 else 2767 src_offset = 0; 2768 copy_bitwise (value_contents_writeable (container) + offset_in_container, 2769 value_bitpos (container) + bit_offset_in_container, 2770 value_contents (val), src_offset, bits, 1); 2771 } 2772 else 2773 copy_bitwise (value_contents_writeable (container) + offset_in_container, 2774 value_bitpos (container) + bit_offset_in_container, 2775 value_contents (val), 0, bits, 0); 2776} 2777 2778/* Determine if TYPE is an access to an unconstrained array. */ 2779 2780bool 2781ada_is_access_to_unconstrained_array (struct type *type) 2782{ 2783 return (TYPE_CODE (type) == TYPE_CODE_TYPEDEF 2784 && is_thick_pntr (ada_typedef_target_type (type))); 2785} 2786 2787/* The value of the element of array ARR at the ARITY indices given in IND. 2788 ARR may be either a simple array, GNAT array descriptor, or pointer 2789 thereto. */ 2790 2791struct value * 2792ada_value_subscript (struct value *arr, int arity, struct value **ind) 2793{ 2794 int k; 2795 struct value *elt; 2796 struct type *elt_type; 2797 2798 elt = ada_coerce_to_simple_array (arr); 2799 2800 elt_type = ada_check_typedef (value_type (elt)); 2801 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY 2802 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0) 2803 return value_subscript_packed (elt, arity, ind); 2804 2805 for (k = 0; k < arity; k += 1) 2806 { 2807 struct type *saved_elt_type = TYPE_TARGET_TYPE (elt_type); 2808 2809 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY) 2810 error (_("too many subscripts (%d expected)"), k); 2811 2812 elt = value_subscript (elt, pos_atr (ind[k])); 2813 2814 if (ada_is_access_to_unconstrained_array (saved_elt_type) 2815 && TYPE_CODE (value_type (elt)) != TYPE_CODE_TYPEDEF) 2816 { 2817 /* The element is a typedef to an unconstrained array, 2818 except that the value_subscript call stripped the 2819 typedef layer. The typedef layer is GNAT's way to 2820 specify that the element is, at the source level, an 2821 access to the unconstrained array, rather than the 2822 unconstrained array. So, we need to restore that 2823 typedef layer, which we can do by forcing the element's 2824 type back to its original type. Otherwise, the returned 2825 value is going to be printed as the array, rather 2826 than as an access. Another symptom of the same issue 2827 would be that an expression trying to dereference the 2828 element would also be improperly rejected. */ 2829 deprecated_set_value_type (elt, saved_elt_type); 2830 } 2831 2832 elt_type = ada_check_typedef (value_type (elt)); 2833 } 2834 2835 return elt; 2836} 2837 2838/* Assuming ARR is a pointer to a GDB array, the value of the element 2839 of *ARR at the ARITY indices given in IND. 2840 Does not read the entire array into memory. 2841 2842 Note: Unlike what one would expect, this function is used instead of 2843 ada_value_subscript for basically all non-packed array types. The reason 2844 for this is that a side effect of doing our own pointer arithmetics instead 2845 of relying on value_subscript is that there is no implicit typedef peeling. 2846 This is important for arrays of array accesses, where it allows us to 2847 preserve the fact that the array's element is an array access, where the 2848 access part os encoded in a typedef layer. */ 2849 2850static struct value * 2851ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind) 2852{ 2853 int k; 2854 struct value *array_ind = ada_value_ind (arr); 2855 struct type *type 2856 = check_typedef (value_enclosing_type (array_ind)); 2857 2858 if (TYPE_CODE (type) == TYPE_CODE_ARRAY 2859 && TYPE_FIELD_BITSIZE (type, 0) > 0) 2860 return value_subscript_packed (array_ind, arity, ind); 2861 2862 for (k = 0; k < arity; k += 1) 2863 { 2864 LONGEST lwb, upb; 2865 struct value *lwb_value; 2866 2867 if (TYPE_CODE (type) != TYPE_CODE_ARRAY) 2868 error (_("too many subscripts (%d expected)"), k); 2869 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)), 2870 value_copy (arr)); 2871 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb); 2872 lwb_value = value_from_longest (value_type(ind[k]), lwb); 2873 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value)); 2874 type = TYPE_TARGET_TYPE (type); 2875 } 2876 2877 return value_ind (arr); 2878} 2879 2880/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the 2881 actual type of ARRAY_PTR is ignored), returns the Ada slice of 2882 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of 2883 this array is LOW, as per Ada rules. */ 2884static struct value * 2885ada_value_slice_from_ptr (struct value *array_ptr, struct type *type, 2886 int low, int high) 2887{ 2888 struct type *type0 = ada_check_typedef (type); 2889 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)); 2890 struct type *index_type 2891 = create_static_range_type (NULL, base_index_type, low, high); 2892 struct type *slice_type = create_array_type_with_stride 2893 (NULL, TYPE_TARGET_TYPE (type0), index_type, 2894 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0), 2895 TYPE_FIELD_BITSIZE (type0, 0)); 2896 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)); 2897 LONGEST base_low_pos, low_pos; 2898 CORE_ADDR base; 2899 2900 if (!discrete_position (base_index_type, low, &low_pos) 2901 || !discrete_position (base_index_type, base_low, &base_low_pos)) 2902 { 2903 warning (_("unable to get positions in slice, use bounds instead")); 2904 low_pos = low; 2905 base_low_pos = base_low; 2906 } 2907 2908 base = value_as_address (array_ptr) 2909 + ((low_pos - base_low_pos) 2910 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0))); 2911 return value_at_lazy (slice_type, base); 2912} 2913 2914 2915static struct value * 2916ada_value_slice (struct value *array, int low, int high) 2917{ 2918 struct type *type = ada_check_typedef (value_type (array)); 2919 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)); 2920 struct type *index_type 2921 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high); 2922 struct type *slice_type = create_array_type_with_stride 2923 (NULL, TYPE_TARGET_TYPE (type), index_type, 2924 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type), 2925 TYPE_FIELD_BITSIZE (type, 0)); 2926 LONGEST low_pos, high_pos; 2927 2928 if (!discrete_position (base_index_type, low, &low_pos) 2929 || !discrete_position (base_index_type, high, &high_pos)) 2930 { 2931 warning (_("unable to get positions in slice, use bounds instead")); 2932 low_pos = low; 2933 high_pos = high; 2934 } 2935 2936 return value_cast (slice_type, 2937 value_slice (array, low, high_pos - low_pos + 1)); 2938} 2939 2940/* If type is a record type in the form of a standard GNAT array 2941 descriptor, returns the number of dimensions for type. If arr is a 2942 simple array, returns the number of "array of"s that prefix its 2943 type designation. Otherwise, returns 0. */ 2944 2945int 2946ada_array_arity (struct type *type) 2947{ 2948 int arity; 2949 2950 if (type == NULL) 2951 return 0; 2952 2953 type = desc_base_type (type); 2954 2955 arity = 0; 2956 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 2957 return desc_arity (desc_bounds_type (type)); 2958 else 2959 while (TYPE_CODE (type) == TYPE_CODE_ARRAY) 2960 { 2961 arity += 1; 2962 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 2963 } 2964 2965 return arity; 2966} 2967 2968/* If TYPE is a record type in the form of a standard GNAT array 2969 descriptor or a simple array type, returns the element type for 2970 TYPE after indexing by NINDICES indices, or by all indices if 2971 NINDICES is -1. Otherwise, returns NULL. */ 2972 2973struct type * 2974ada_array_element_type (struct type *type, int nindices) 2975{ 2976 type = desc_base_type (type); 2977 2978 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 2979 { 2980 int k; 2981 struct type *p_array_type; 2982 2983 p_array_type = desc_data_target_type (type); 2984 2985 k = ada_array_arity (type); 2986 if (k == 0) 2987 return NULL; 2988 2989 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */ 2990 if (nindices >= 0 && k > nindices) 2991 k = nindices; 2992 while (k > 0 && p_array_type != NULL) 2993 { 2994 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type)); 2995 k -= 1; 2996 } 2997 return p_array_type; 2998 } 2999 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY) 3000 { 3001 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 3002 { 3003 type = TYPE_TARGET_TYPE (type); 3004 nindices -= 1; 3005 } 3006 return type; 3007 } 3008 3009 return NULL; 3010} 3011 3012/* The type of nth index in arrays of given type (n numbering from 1). 3013 Does not examine memory. Throws an error if N is invalid or TYPE 3014 is not an array type. NAME is the name of the Ada attribute being 3015 evaluated ('range, 'first, 'last, or 'length); it is used in building 3016 the error message. */ 3017 3018static struct type * 3019ada_index_type (struct type *type, int n, const char *name) 3020{ 3021 struct type *result_type; 3022 3023 type = desc_base_type (type); 3024 3025 if (n < 0 || n > ada_array_arity (type)) 3026 error (_("invalid dimension number to '%s"), name); 3027 3028 if (ada_is_simple_array_type (type)) 3029 { 3030 int i; 3031 3032 for (i = 1; i < n; i += 1) 3033 type = TYPE_TARGET_TYPE (type); 3034 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)); 3035 /* FIXME: The stabs type r(0,0);bound;bound in an array type 3036 has a target type of TYPE_CODE_UNDEF. We compensate here, but 3037 perhaps stabsread.c would make more sense. */ 3038 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF) 3039 result_type = NULL; 3040 } 3041 else 3042 { 3043 result_type = desc_index_type (desc_bounds_type (type), n); 3044 if (result_type == NULL) 3045 error (_("attempt to take bound of something that is not an array")); 3046 } 3047 3048 return result_type; 3049} 3050 3051/* Given that arr is an array type, returns the lower bound of the 3052 Nth index (numbering from 1) if WHICH is 0, and the upper bound if 3053 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an 3054 array-descriptor type. It works for other arrays with bounds supplied 3055 by run-time quantities other than discriminants. */ 3056 3057static LONGEST 3058ada_array_bound_from_type (struct type *arr_type, int n, int which) 3059{ 3060 struct type *type, *index_type_desc, *index_type; 3061 int i; 3062 3063 gdb_assert (which == 0 || which == 1); 3064 3065 if (ada_is_constrained_packed_array_type (arr_type)) 3066 arr_type = decode_constrained_packed_array_type (arr_type); 3067 3068 if (arr_type == NULL || !ada_is_simple_array_type (arr_type)) 3069 return (LONGEST) - which; 3070 3071 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR) 3072 type = TYPE_TARGET_TYPE (arr_type); 3073 else 3074 type = arr_type; 3075 3076 if (TYPE_FIXED_INSTANCE (type)) 3077 { 3078 /* The array has already been fixed, so we do not need to 3079 check the parallel ___XA type again. That encoding has 3080 already been applied, so ignore it now. */ 3081 index_type_desc = NULL; 3082 } 3083 else 3084 { 3085 index_type_desc = ada_find_parallel_type (type, "___XA"); 3086 ada_fixup_array_indexes_type (index_type_desc); 3087 } 3088 3089 if (index_type_desc != NULL) 3090 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1), 3091 NULL); 3092 else 3093 { 3094 struct type *elt_type = check_typedef (type); 3095 3096 for (i = 1; i < n; i++) 3097 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type)); 3098 3099 index_type = TYPE_INDEX_TYPE (elt_type); 3100 } 3101 3102 return 3103 (LONGEST) (which == 0 3104 ? ada_discrete_type_low_bound (index_type) 3105 : ada_discrete_type_high_bound (index_type)); 3106} 3107 3108/* Given that arr is an array value, returns the lower bound of the 3109 nth index (numbering from 1) if WHICH is 0, and the upper bound if 3110 WHICH is 1. This routine will also work for arrays with bounds 3111 supplied by run-time quantities other than discriminants. */ 3112 3113static LONGEST 3114ada_array_bound (struct value *arr, int n, int which) 3115{ 3116 struct type *arr_type; 3117 3118 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR) 3119 arr = value_ind (arr); 3120 arr_type = value_enclosing_type (arr); 3121 3122 if (ada_is_constrained_packed_array_type (arr_type)) 3123 return ada_array_bound (decode_constrained_packed_array (arr), n, which); 3124 else if (ada_is_simple_array_type (arr_type)) 3125 return ada_array_bound_from_type (arr_type, n, which); 3126 else 3127 return value_as_long (desc_one_bound (desc_bounds (arr), n, which)); 3128} 3129 3130/* Given that arr is an array value, returns the length of the 3131 nth index. This routine will also work for arrays with bounds 3132 supplied by run-time quantities other than discriminants. 3133 Does not work for arrays indexed by enumeration types with representation 3134 clauses at the moment. */ 3135 3136static LONGEST 3137ada_array_length (struct value *arr, int n) 3138{ 3139 struct type *arr_type, *index_type; 3140 int low, high; 3141 3142 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR) 3143 arr = value_ind (arr); 3144 arr_type = value_enclosing_type (arr); 3145 3146 if (ada_is_constrained_packed_array_type (arr_type)) 3147 return ada_array_length (decode_constrained_packed_array (arr), n); 3148 3149 if (ada_is_simple_array_type (arr_type)) 3150 { 3151 low = ada_array_bound_from_type (arr_type, n, 0); 3152 high = ada_array_bound_from_type (arr_type, n, 1); 3153 } 3154 else 3155 { 3156 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0)); 3157 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1)); 3158 } 3159 3160 arr_type = check_typedef (arr_type); 3161 index_type = ada_index_type (arr_type, n, "length"); 3162 if (index_type != NULL) 3163 { 3164 struct type *base_type; 3165 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE) 3166 base_type = TYPE_TARGET_TYPE (index_type); 3167 else 3168 base_type = index_type; 3169 3170 low = pos_atr (value_from_longest (base_type, low)); 3171 high = pos_atr (value_from_longest (base_type, high)); 3172 } 3173 return high - low + 1; 3174} 3175 3176/* An empty array whose type is that of ARR_TYPE (an array type), 3177 with bounds LOW to LOW-1. */ 3178 3179static struct value * 3180empty_array (struct type *arr_type, int low) 3181{ 3182 struct type *arr_type0 = ada_check_typedef (arr_type); 3183 struct type *index_type 3184 = create_static_range_type 3185 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1); 3186 struct type *elt_type = ada_array_element_type (arr_type0, 1); 3187 3188 return allocate_value (create_array_type (NULL, elt_type, index_type)); 3189} 3190 3191 3192 /* Name resolution */ 3193 3194/* The "decoded" name for the user-definable Ada operator corresponding 3195 to OP. */ 3196 3197static const char * 3198ada_decoded_op_name (enum exp_opcode op) 3199{ 3200 int i; 3201 3202 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1) 3203 { 3204 if (ada_opname_table[i].op == op) 3205 return ada_opname_table[i].decoded; 3206 } 3207 error (_("Could not find operator name for opcode")); 3208} 3209 3210 3211/* Same as evaluate_type (*EXP), but resolves ambiguous symbol 3212 references (marked by OP_VAR_VALUE nodes in which the symbol has an 3213 undefined namespace) and converts operators that are 3214 user-defined into appropriate function calls. If CONTEXT_TYPE is 3215 non-null, it provides a preferred result type [at the moment, only 3216 type void has any effect---causing procedures to be preferred over 3217 functions in calls]. A null CONTEXT_TYPE indicates that a non-void 3218 return type is preferred. May change (expand) *EXP. */ 3219 3220static void 3221resolve (expression_up *expp, int void_context_p) 3222{ 3223 struct type *context_type = NULL; 3224 int pc = 0; 3225 3226 if (void_context_p) 3227 context_type = builtin_type ((*expp)->gdbarch)->builtin_void; 3228 3229 resolve_subexp (expp, &pc, 1, context_type); 3230} 3231 3232/* Resolve the operator of the subexpression beginning at 3233 position *POS of *EXPP. "Resolving" consists of replacing 3234 the symbols that have undefined namespaces in OP_VAR_VALUE nodes 3235 with their resolutions, replacing built-in operators with 3236 function calls to user-defined operators, where appropriate, and, 3237 when DEPROCEDURE_P is non-zero, converting function-valued variables 3238 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions 3239 are as in ada_resolve, above. */ 3240 3241static struct value * 3242resolve_subexp (expression_up *expp, int *pos, int deprocedure_p, 3243 struct type *context_type) 3244{ 3245 int pc = *pos; 3246 int i; 3247 struct expression *exp; /* Convenience: == *expp. */ 3248 enum exp_opcode op = (*expp)->elts[pc].opcode; 3249 struct value **argvec; /* Vector of operand types (alloca'ed). */ 3250 int nargs; /* Number of operands. */ 3251 int oplen; 3252 3253 argvec = NULL; 3254 nargs = 0; 3255 exp = expp->get (); 3256 3257 /* Pass one: resolve operands, saving their types and updating *pos, 3258 if needed. */ 3259 switch (op) 3260 { 3261 case OP_FUNCALL: 3262 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE 3263 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 3264 *pos += 7; 3265 else 3266 { 3267 *pos += 3; 3268 resolve_subexp (expp, pos, 0, NULL); 3269 } 3270 nargs = longest_to_int (exp->elts[pc + 1].longconst); 3271 break; 3272 3273 case UNOP_ADDR: 3274 *pos += 1; 3275 resolve_subexp (expp, pos, 0, NULL); 3276 break; 3277 3278 case UNOP_QUAL: 3279 *pos += 3; 3280 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type)); 3281 break; 3282 3283 case OP_ATR_MODULUS: 3284 case OP_ATR_SIZE: 3285 case OP_ATR_TAG: 3286 case OP_ATR_FIRST: 3287 case OP_ATR_LAST: 3288 case OP_ATR_LENGTH: 3289 case OP_ATR_POS: 3290 case OP_ATR_VAL: 3291 case OP_ATR_MIN: 3292 case OP_ATR_MAX: 3293 case TERNOP_IN_RANGE: 3294 case BINOP_IN_BOUNDS: 3295 case UNOP_IN_RANGE: 3296 case OP_AGGREGATE: 3297 case OP_OTHERS: 3298 case OP_CHOICES: 3299 case OP_POSITIONAL: 3300 case OP_DISCRETE_RANGE: 3301 case OP_NAME: 3302 ada_forward_operator_length (exp, pc, &oplen, &nargs); 3303 *pos += oplen; 3304 break; 3305 3306 case BINOP_ASSIGN: 3307 { 3308 struct value *arg1; 3309 3310 *pos += 1; 3311 arg1 = resolve_subexp (expp, pos, 0, NULL); 3312 if (arg1 == NULL) 3313 resolve_subexp (expp, pos, 1, NULL); 3314 else 3315 resolve_subexp (expp, pos, 1, value_type (arg1)); 3316 break; 3317 } 3318 3319 case UNOP_CAST: 3320 *pos += 3; 3321 nargs = 1; 3322 break; 3323 3324 case BINOP_ADD: 3325 case BINOP_SUB: 3326 case BINOP_MUL: 3327 case BINOP_DIV: 3328 case BINOP_REM: 3329 case BINOP_MOD: 3330 case BINOP_EXP: 3331 case BINOP_CONCAT: 3332 case BINOP_LOGICAL_AND: 3333 case BINOP_LOGICAL_OR: 3334 case BINOP_BITWISE_AND: 3335 case BINOP_BITWISE_IOR: 3336 case BINOP_BITWISE_XOR: 3337 3338 case BINOP_EQUAL: 3339 case BINOP_NOTEQUAL: 3340 case BINOP_LESS: 3341 case BINOP_GTR: 3342 case BINOP_LEQ: 3343 case BINOP_GEQ: 3344 3345 case BINOP_REPEAT: 3346 case BINOP_SUBSCRIPT: 3347 case BINOP_COMMA: 3348 *pos += 1; 3349 nargs = 2; 3350 break; 3351 3352 case UNOP_NEG: 3353 case UNOP_PLUS: 3354 case UNOP_LOGICAL_NOT: 3355 case UNOP_ABS: 3356 case UNOP_IND: 3357 *pos += 1; 3358 nargs = 1; 3359 break; 3360 3361 case OP_LONG: 3362 case OP_FLOAT: 3363 case OP_VAR_VALUE: 3364 case OP_VAR_MSYM_VALUE: 3365 *pos += 4; 3366 break; 3367 3368 case OP_TYPE: 3369 case OP_BOOL: 3370 case OP_LAST: 3371 case OP_INTERNALVAR: 3372 *pos += 3; 3373 break; 3374 3375 case UNOP_MEMVAL: 3376 *pos += 3; 3377 nargs = 1; 3378 break; 3379 3380 case OP_REGISTER: 3381 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1); 3382 break; 3383 3384 case STRUCTOP_STRUCT: 3385 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1); 3386 nargs = 1; 3387 break; 3388 3389 case TERNOP_SLICE: 3390 *pos += 1; 3391 nargs = 3; 3392 break; 3393 3394 case OP_STRING: 3395 break; 3396 3397 default: 3398 error (_("Unexpected operator during name resolution")); 3399 } 3400 3401 argvec = XALLOCAVEC (struct value *, nargs + 1); 3402 for (i = 0; i < nargs; i += 1) 3403 argvec[i] = resolve_subexp (expp, pos, 1, NULL); 3404 argvec[i] = NULL; 3405 exp = expp->get (); 3406 3407 /* Pass two: perform any resolution on principal operator. */ 3408 switch (op) 3409 { 3410 default: 3411 break; 3412 3413 case OP_VAR_VALUE: 3414 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN) 3415 { 3416 std::vector<struct block_symbol> candidates; 3417 int n_candidates; 3418 3419 n_candidates = 3420 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME 3421 (exp->elts[pc + 2].symbol), 3422 exp->elts[pc + 1].block, VAR_DOMAIN, 3423 &candidates); 3424 3425 if (n_candidates > 1) 3426 { 3427 /* Types tend to get re-introduced locally, so if there 3428 are any local symbols that are not types, first filter 3429 out all types. */ 3430 int j; 3431 for (j = 0; j < n_candidates; j += 1) 3432 switch (SYMBOL_CLASS (candidates[j].symbol)) 3433 { 3434 case LOC_REGISTER: 3435 case LOC_ARG: 3436 case LOC_REF_ARG: 3437 case LOC_REGPARM_ADDR: 3438 case LOC_LOCAL: 3439 case LOC_COMPUTED: 3440 goto FoundNonType; 3441 default: 3442 break; 3443 } 3444 FoundNonType: 3445 if (j < n_candidates) 3446 { 3447 j = 0; 3448 while (j < n_candidates) 3449 { 3450 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF) 3451 { 3452 candidates[j] = candidates[n_candidates - 1]; 3453 n_candidates -= 1; 3454 } 3455 else 3456 j += 1; 3457 } 3458 } 3459 } 3460 3461 if (n_candidates == 0) 3462 error (_("No definition found for %s"), 3463 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3464 else if (n_candidates == 1) 3465 i = 0; 3466 else if (deprocedure_p 3467 && !is_nonfunction (candidates.data (), n_candidates)) 3468 { 3469 i = ada_resolve_function 3470 (candidates.data (), n_candidates, NULL, 0, 3471 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol), 3472 context_type); 3473 if (i < 0) 3474 error (_("Could not find a match for %s"), 3475 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3476 } 3477 else 3478 { 3479 printf_filtered (_("Multiple matches for %s\n"), 3480 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3481 user_select_syms (candidates.data (), n_candidates, 1); 3482 i = 0; 3483 } 3484 3485 exp->elts[pc + 1].block = candidates[i].block; 3486 exp->elts[pc + 2].symbol = candidates[i].symbol; 3487 innermost_block.update (candidates[i]); 3488 } 3489 3490 if (deprocedure_p 3491 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol)) 3492 == TYPE_CODE_FUNC)) 3493 { 3494 replace_operator_with_call (expp, pc, 0, 4, 3495 exp->elts[pc + 2].symbol, 3496 exp->elts[pc + 1].block); 3497 exp = expp->get (); 3498 } 3499 break; 3500 3501 case OP_FUNCALL: 3502 { 3503 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE 3504 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 3505 { 3506 std::vector<struct block_symbol> candidates; 3507 int n_candidates; 3508 3509 n_candidates = 3510 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME 3511 (exp->elts[pc + 5].symbol), 3512 exp->elts[pc + 4].block, VAR_DOMAIN, 3513 &candidates); 3514 3515 if (n_candidates == 1) 3516 i = 0; 3517 else 3518 { 3519 i = ada_resolve_function 3520 (candidates.data (), n_candidates, 3521 argvec, nargs, 3522 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol), 3523 context_type); 3524 if (i < 0) 3525 error (_("Could not find a match for %s"), 3526 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol)); 3527 } 3528 3529 exp->elts[pc + 4].block = candidates[i].block; 3530 exp->elts[pc + 5].symbol = candidates[i].symbol; 3531 innermost_block.update (candidates[i]); 3532 } 3533 } 3534 break; 3535 case BINOP_ADD: 3536 case BINOP_SUB: 3537 case BINOP_MUL: 3538 case BINOP_DIV: 3539 case BINOP_REM: 3540 case BINOP_MOD: 3541 case BINOP_CONCAT: 3542 case BINOP_BITWISE_AND: 3543 case BINOP_BITWISE_IOR: 3544 case BINOP_BITWISE_XOR: 3545 case BINOP_EQUAL: 3546 case BINOP_NOTEQUAL: 3547 case BINOP_LESS: 3548 case BINOP_GTR: 3549 case BINOP_LEQ: 3550 case BINOP_GEQ: 3551 case BINOP_EXP: 3552 case UNOP_NEG: 3553 case UNOP_PLUS: 3554 case UNOP_LOGICAL_NOT: 3555 case UNOP_ABS: 3556 if (possible_user_operator_p (op, argvec)) 3557 { 3558 std::vector<struct block_symbol> candidates; 3559 int n_candidates; 3560 3561 n_candidates = 3562 ada_lookup_symbol_list (ada_decoded_op_name (op), 3563 (struct block *) NULL, VAR_DOMAIN, 3564 &candidates); 3565 3566 i = ada_resolve_function (candidates.data (), n_candidates, argvec, 3567 nargs, ada_decoded_op_name (op), NULL); 3568 if (i < 0) 3569 break; 3570 3571 replace_operator_with_call (expp, pc, nargs, 1, 3572 candidates[i].symbol, 3573 candidates[i].block); 3574 exp = expp->get (); 3575 } 3576 break; 3577 3578 case OP_TYPE: 3579 case OP_REGISTER: 3580 return NULL; 3581 } 3582 3583 *pos = pc; 3584 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE) 3585 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS, 3586 exp->elts[pc + 1].objfile, 3587 exp->elts[pc + 2].msymbol); 3588 else 3589 return evaluate_subexp_type (exp, pos); 3590} 3591 3592/* Return non-zero if formal type FTYPE matches actual type ATYPE. If 3593 MAY_DEREF is non-zero, the formal may be a pointer and the actual 3594 a non-pointer. */ 3595/* The term "match" here is rather loose. The match is heuristic and 3596 liberal. */ 3597 3598static int 3599ada_type_match (struct type *ftype, struct type *atype, int may_deref) 3600{ 3601 ftype = ada_check_typedef (ftype); 3602 atype = ada_check_typedef (atype); 3603 3604 if (TYPE_CODE (ftype) == TYPE_CODE_REF) 3605 ftype = TYPE_TARGET_TYPE (ftype); 3606 if (TYPE_CODE (atype) == TYPE_CODE_REF) 3607 atype = TYPE_TARGET_TYPE (atype); 3608 3609 switch (TYPE_CODE (ftype)) 3610 { 3611 default: 3612 return TYPE_CODE (ftype) == TYPE_CODE (atype); 3613 case TYPE_CODE_PTR: 3614 if (TYPE_CODE (atype) == TYPE_CODE_PTR) 3615 return ada_type_match (TYPE_TARGET_TYPE (ftype), 3616 TYPE_TARGET_TYPE (atype), 0); 3617 else 3618 return (may_deref 3619 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0)); 3620 case TYPE_CODE_INT: 3621 case TYPE_CODE_ENUM: 3622 case TYPE_CODE_RANGE: 3623 switch (TYPE_CODE (atype)) 3624 { 3625 case TYPE_CODE_INT: 3626 case TYPE_CODE_ENUM: 3627 case TYPE_CODE_RANGE: 3628 return 1; 3629 default: 3630 return 0; 3631 } 3632 3633 case TYPE_CODE_ARRAY: 3634 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY 3635 || ada_is_array_descriptor_type (atype)); 3636 3637 case TYPE_CODE_STRUCT: 3638 if (ada_is_array_descriptor_type (ftype)) 3639 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY 3640 || ada_is_array_descriptor_type (atype)); 3641 else 3642 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT 3643 && !ada_is_array_descriptor_type (atype)); 3644 3645 case TYPE_CODE_UNION: 3646 case TYPE_CODE_FLT: 3647 return (TYPE_CODE (atype) == TYPE_CODE (ftype)); 3648 } 3649} 3650 3651/* Return non-zero if the formals of FUNC "sufficiently match" the 3652 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC 3653 may also be an enumeral, in which case it is treated as a 0- 3654 argument function. */ 3655 3656static int 3657ada_args_match (struct symbol *func, struct value **actuals, int n_actuals) 3658{ 3659 int i; 3660 struct type *func_type = SYMBOL_TYPE (func); 3661 3662 if (SYMBOL_CLASS (func) == LOC_CONST 3663 && TYPE_CODE (func_type) == TYPE_CODE_ENUM) 3664 return (n_actuals == 0); 3665 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC) 3666 return 0; 3667 3668 if (TYPE_NFIELDS (func_type) != n_actuals) 3669 return 0; 3670 3671 for (i = 0; i < n_actuals; i += 1) 3672 { 3673 if (actuals[i] == NULL) 3674 return 0; 3675 else 3676 { 3677 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, 3678 i)); 3679 struct type *atype = ada_check_typedef (value_type (actuals[i])); 3680 3681 if (!ada_type_match (ftype, atype, 1)) 3682 return 0; 3683 } 3684 } 3685 return 1; 3686} 3687 3688/* False iff function type FUNC_TYPE definitely does not produce a value 3689 compatible with type CONTEXT_TYPE. Conservatively returns 1 if 3690 FUNC_TYPE is not a valid function type with a non-null return type 3691 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */ 3692 3693static int 3694return_match (struct type *func_type, struct type *context_type) 3695{ 3696 struct type *return_type; 3697 3698 if (func_type == NULL) 3699 return 1; 3700 3701 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC) 3702 return_type = get_base_type (TYPE_TARGET_TYPE (func_type)); 3703 else 3704 return_type = get_base_type (func_type); 3705 if (return_type == NULL) 3706 return 1; 3707 3708 context_type = get_base_type (context_type); 3709 3710 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM) 3711 return context_type == NULL || return_type == context_type; 3712 else if (context_type == NULL) 3713 return TYPE_CODE (return_type) != TYPE_CODE_VOID; 3714 else 3715 return TYPE_CODE (return_type) == TYPE_CODE (context_type); 3716} 3717 3718 3719/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the 3720 function (if any) that matches the types of the NARGS arguments in 3721 ARGS. If CONTEXT_TYPE is non-null and there is at least one match 3722 that returns that type, then eliminate matches that don't. If 3723 CONTEXT_TYPE is void and there is at least one match that does not 3724 return void, eliminate all matches that do. 3725 3726 Asks the user if there is more than one match remaining. Returns -1 3727 if there is no such symbol or none is selected. NAME is used 3728 solely for messages. May re-arrange and modify SYMS in 3729 the process; the index returned is for the modified vector. */ 3730 3731static int 3732ada_resolve_function (struct block_symbol syms[], 3733 int nsyms, struct value **args, int nargs, 3734 const char *name, struct type *context_type) 3735{ 3736 int fallback; 3737 int k; 3738 int m; /* Number of hits */ 3739 3740 m = 0; 3741 /* In the first pass of the loop, we only accept functions matching 3742 context_type. If none are found, we add a second pass of the loop 3743 where every function is accepted. */ 3744 for (fallback = 0; m == 0 && fallback < 2; fallback++) 3745 { 3746 for (k = 0; k < nsyms; k += 1) 3747 { 3748 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol)); 3749 3750 if (ada_args_match (syms[k].symbol, args, nargs) 3751 && (fallback || return_match (type, context_type))) 3752 { 3753 syms[m] = syms[k]; 3754 m += 1; 3755 } 3756 } 3757 } 3758 3759 /* If we got multiple matches, ask the user which one to use. Don't do this 3760 interactive thing during completion, though, as the purpose of the 3761 completion is providing a list of all possible matches. Prompting the 3762 user to filter it down would be completely unexpected in this case. */ 3763 if (m == 0) 3764 return -1; 3765 else if (m > 1 && !parse_completion) 3766 { 3767 printf_filtered (_("Multiple matches for %s\n"), name); 3768 user_select_syms (syms, m, 1); 3769 return 0; 3770 } 3771 return 0; 3772} 3773 3774/* Returns true (non-zero) iff decoded name N0 should appear before N1 3775 in a listing of choices during disambiguation (see sort_choices, below). 3776 The idea is that overloadings of a subprogram name from the 3777 same package should sort in their source order. We settle for ordering 3778 such symbols by their trailing number (__N or $N). */ 3779 3780static int 3781encoded_ordered_before (const char *N0, const char *N1) 3782{ 3783 if (N1 == NULL) 3784 return 0; 3785 else if (N0 == NULL) 3786 return 1; 3787 else 3788 { 3789 int k0, k1; 3790 3791 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1) 3792 ; 3793 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1) 3794 ; 3795 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000' 3796 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000') 3797 { 3798 int n0, n1; 3799 3800 n0 = k0; 3801 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_') 3802 n0 -= 1; 3803 n1 = k1; 3804 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_') 3805 n1 -= 1; 3806 if (n0 == n1 && strncmp (N0, N1, n0) == 0) 3807 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1)); 3808 } 3809 return (strcmp (N0, N1) < 0); 3810 } 3811} 3812 3813/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the 3814 encoded names. */ 3815 3816static void 3817sort_choices (struct block_symbol syms[], int nsyms) 3818{ 3819 int i; 3820 3821 for (i = 1; i < nsyms; i += 1) 3822 { 3823 struct block_symbol sym = syms[i]; 3824 int j; 3825 3826 for (j = i - 1; j >= 0; j -= 1) 3827 { 3828 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol), 3829 SYMBOL_LINKAGE_NAME (sym.symbol))) 3830 break; 3831 syms[j + 1] = syms[j]; 3832 } 3833 syms[j + 1] = sym; 3834 } 3835} 3836 3837/* Whether GDB should display formals and return types for functions in the 3838 overloads selection menu. */ 3839static int print_signatures = 1; 3840 3841/* Print the signature for SYM on STREAM according to the FLAGS options. For 3842 all but functions, the signature is just the name of the symbol. For 3843 functions, this is the name of the function, the list of types for formals 3844 and the return type (if any). */ 3845 3846static void 3847ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym, 3848 const struct type_print_options *flags) 3849{ 3850 struct type *type = SYMBOL_TYPE (sym); 3851 3852 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym)); 3853 if (!print_signatures 3854 || type == NULL 3855 || TYPE_CODE (type) != TYPE_CODE_FUNC) 3856 return; 3857 3858 if (TYPE_NFIELDS (type) > 0) 3859 { 3860 int i; 3861 3862 fprintf_filtered (stream, " ("); 3863 for (i = 0; i < TYPE_NFIELDS (type); ++i) 3864 { 3865 if (i > 0) 3866 fprintf_filtered (stream, "; "); 3867 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0, 3868 flags); 3869 } 3870 fprintf_filtered (stream, ")"); 3871 } 3872 if (TYPE_TARGET_TYPE (type) != NULL 3873 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID) 3874 { 3875 fprintf_filtered (stream, " return "); 3876 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags); 3877 } 3878} 3879 3880/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0 3881 by asking the user (if necessary), returning the number selected, 3882 and setting the first elements of SYMS items. Error if no symbols 3883 selected. */ 3884 3885/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought 3886 to be re-integrated one of these days. */ 3887 3888int 3889user_select_syms (struct block_symbol *syms, int nsyms, int max_results) 3890{ 3891 int i; 3892 int *chosen = XALLOCAVEC (int , nsyms); 3893 int n_chosen; 3894 int first_choice = (max_results == 1) ? 1 : 2; 3895 const char *select_mode = multiple_symbols_select_mode (); 3896 3897 if (max_results < 1) 3898 error (_("Request to select 0 symbols!")); 3899 if (nsyms <= 1) 3900 return nsyms; 3901 3902 if (select_mode == multiple_symbols_cancel) 3903 error (_("\ 3904canceled because the command is ambiguous\n\ 3905See set/show multiple-symbol.")); 3906 3907 /* If select_mode is "all", then return all possible symbols. 3908 Only do that if more than one symbol can be selected, of course. 3909 Otherwise, display the menu as usual. */ 3910 if (select_mode == multiple_symbols_all && max_results > 1) 3911 return nsyms; 3912 3913 printf_filtered (_("[0] cancel\n")); 3914 if (max_results > 1) 3915 printf_filtered (_("[1] all\n")); 3916 3917 sort_choices (syms, nsyms); 3918 3919 for (i = 0; i < nsyms; i += 1) 3920 { 3921 if (syms[i].symbol == NULL) 3922 continue; 3923 3924 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK) 3925 { 3926 struct symtab_and_line sal = 3927 find_function_start_sal (syms[i].symbol, 1); 3928 3929 printf_filtered ("[%d] ", i + first_choice); 3930 ada_print_symbol_signature (gdb_stdout, syms[i].symbol, 3931 &type_print_raw_options); 3932 if (sal.symtab == NULL) 3933 printf_filtered (_(" at <no source file available>:%d\n"), 3934 sal.line); 3935 else 3936 printf_filtered (_(" at %s:%d\n"), 3937 symtab_to_filename_for_display (sal.symtab), 3938 sal.line); 3939 continue; 3940 } 3941 else 3942 { 3943 int is_enumeral = 3944 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST 3945 && SYMBOL_TYPE (syms[i].symbol) != NULL 3946 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM); 3947 struct symtab *symtab = NULL; 3948 3949 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol)) 3950 symtab = symbol_symtab (syms[i].symbol); 3951 3952 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL) 3953 { 3954 printf_filtered ("[%d] ", i + first_choice); 3955 ada_print_symbol_signature (gdb_stdout, syms[i].symbol, 3956 &type_print_raw_options); 3957 printf_filtered (_(" at %s:%d\n"), 3958 symtab_to_filename_for_display (symtab), 3959 SYMBOL_LINE (syms[i].symbol)); 3960 } 3961 else if (is_enumeral 3962 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL) 3963 { 3964 printf_filtered (("[%d] "), i + first_choice); 3965 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL, 3966 gdb_stdout, -1, 0, &type_print_raw_options); 3967 printf_filtered (_("'(%s) (enumeral)\n"), 3968 SYMBOL_PRINT_NAME (syms[i].symbol)); 3969 } 3970 else 3971 { 3972 printf_filtered ("[%d] ", i + first_choice); 3973 ada_print_symbol_signature (gdb_stdout, syms[i].symbol, 3974 &type_print_raw_options); 3975 3976 if (symtab != NULL) 3977 printf_filtered (is_enumeral 3978 ? _(" in %s (enumeral)\n") 3979 : _(" at %s:?\n"), 3980 symtab_to_filename_for_display (symtab)); 3981 else 3982 printf_filtered (is_enumeral 3983 ? _(" (enumeral)\n") 3984 : _(" at ?\n")); 3985 } 3986 } 3987 } 3988 3989 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1, 3990 "overload-choice"); 3991 3992 for (i = 0; i < n_chosen; i += 1) 3993 syms[i] = syms[chosen[i]]; 3994 3995 return n_chosen; 3996} 3997 3998/* Read and validate a set of numeric choices from the user in the 3999 range 0 .. N_CHOICES-1. Place the results in increasing 4000 order in CHOICES[0 .. N-1], and return N. 4001 4002 The user types choices as a sequence of numbers on one line 4003 separated by blanks, encoding them as follows: 4004 4005 + A choice of 0 means to cancel the selection, throwing an error. 4006 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1. 4007 + The user chooses k by typing k+IS_ALL_CHOICE+1. 4008 4009 The user is not allowed to choose more than MAX_RESULTS values. 4010 4011 ANNOTATION_SUFFIX, if present, is used to annotate the input 4012 prompts (for use with the -f switch). */ 4013 4014int 4015get_selections (int *choices, int n_choices, int max_results, 4016 int is_all_choice, const char *annotation_suffix) 4017{ 4018 char *args; 4019 const char *prompt; 4020 int n_chosen; 4021 int first_choice = is_all_choice ? 2 : 1; 4022 4023 prompt = getenv ("PS2"); 4024 if (prompt == NULL) 4025 prompt = "> "; 4026 4027 args = command_line_input (prompt, annotation_suffix); 4028 4029 if (args == NULL) 4030 error_no_arg (_("one or more choice numbers")); 4031 4032 n_chosen = 0; 4033 4034 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending 4035 order, as given in args. Choices are validated. */ 4036 while (1) 4037 { 4038 char *args2; 4039 int choice, j; 4040 4041 args = skip_spaces (args); 4042 if (*args == '\0' && n_chosen == 0) 4043 error_no_arg (_("one or more choice numbers")); 4044 else if (*args == '\0') 4045 break; 4046 4047 choice = strtol (args, &args2, 10); 4048 if (args == args2 || choice < 0 4049 || choice > n_choices + first_choice - 1) 4050 error (_("Argument must be choice number")); 4051 args = args2; 4052 4053 if (choice == 0) 4054 error (_("cancelled")); 4055 4056 if (choice < first_choice) 4057 { 4058 n_chosen = n_choices; 4059 for (j = 0; j < n_choices; j += 1) 4060 choices[j] = j; 4061 break; 4062 } 4063 choice -= first_choice; 4064 4065 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1) 4066 { 4067 } 4068 4069 if (j < 0 || choice != choices[j]) 4070 { 4071 int k; 4072 4073 for (k = n_chosen - 1; k > j; k -= 1) 4074 choices[k + 1] = choices[k]; 4075 choices[j + 1] = choice; 4076 n_chosen += 1; 4077 } 4078 } 4079 4080 if (n_chosen > max_results) 4081 error (_("Select no more than %d of the above"), max_results); 4082 4083 return n_chosen; 4084} 4085 4086/* Replace the operator of length OPLEN at position PC in *EXPP with a call 4087 on the function identified by SYM and BLOCK, and taking NARGS 4088 arguments. Update *EXPP as needed to hold more space. */ 4089 4090static void 4091replace_operator_with_call (expression_up *expp, int pc, int nargs, 4092 int oplen, struct symbol *sym, 4093 const struct block *block) 4094{ 4095 /* A new expression, with 6 more elements (3 for funcall, 4 for function 4096 symbol, -oplen for operator being replaced). */ 4097 struct expression *newexp = (struct expression *) 4098 xzalloc (sizeof (struct expression) 4099 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen)); 4100 struct expression *exp = expp->get (); 4101 4102 newexp->nelts = exp->nelts + 7 - oplen; 4103 newexp->language_defn = exp->language_defn; 4104 newexp->gdbarch = exp->gdbarch; 4105 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc)); 4106 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen, 4107 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen)); 4108 4109 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL; 4110 newexp->elts[pc + 1].longconst = (LONGEST) nargs; 4111 4112 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE; 4113 newexp->elts[pc + 4].block = block; 4114 newexp->elts[pc + 5].symbol = sym; 4115 4116 expp->reset (newexp); 4117} 4118 4119/* Type-class predicates */ 4120 4121/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), 4122 or FLOAT). */ 4123 4124static int 4125numeric_type_p (struct type *type) 4126{ 4127 if (type == NULL) 4128 return 0; 4129 else 4130 { 4131 switch (TYPE_CODE (type)) 4132 { 4133 case TYPE_CODE_INT: 4134 case TYPE_CODE_FLT: 4135 return 1; 4136 case TYPE_CODE_RANGE: 4137 return (type == TYPE_TARGET_TYPE (type) 4138 || numeric_type_p (TYPE_TARGET_TYPE (type))); 4139 default: 4140 return 0; 4141 } 4142 } 4143} 4144 4145/* True iff TYPE is integral (an INT or RANGE of INTs). */ 4146 4147static int 4148integer_type_p (struct type *type) 4149{ 4150 if (type == NULL) 4151 return 0; 4152 else 4153 { 4154 switch (TYPE_CODE (type)) 4155 { 4156 case TYPE_CODE_INT: 4157 return 1; 4158 case TYPE_CODE_RANGE: 4159 return (type == TYPE_TARGET_TYPE (type) 4160 || integer_type_p (TYPE_TARGET_TYPE (type))); 4161 default: 4162 return 0; 4163 } 4164 } 4165} 4166 4167/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */ 4168 4169static int 4170scalar_type_p (struct type *type) 4171{ 4172 if (type == NULL) 4173 return 0; 4174 else 4175 { 4176 switch (TYPE_CODE (type)) 4177 { 4178 case TYPE_CODE_INT: 4179 case TYPE_CODE_RANGE: 4180 case TYPE_CODE_ENUM: 4181 case TYPE_CODE_FLT: 4182 return 1; 4183 default: 4184 return 0; 4185 } 4186 } 4187} 4188 4189/* True iff TYPE is discrete (INT, RANGE, ENUM). */ 4190 4191static int 4192discrete_type_p (struct type *type) 4193{ 4194 if (type == NULL) 4195 return 0; 4196 else 4197 { 4198 switch (TYPE_CODE (type)) 4199 { 4200 case TYPE_CODE_INT: 4201 case TYPE_CODE_RANGE: 4202 case TYPE_CODE_ENUM: 4203 case TYPE_CODE_BOOL: 4204 return 1; 4205 default: 4206 return 0; 4207 } 4208 } 4209} 4210 4211/* Returns non-zero if OP with operands in the vector ARGS could be 4212 a user-defined function. Errs on the side of pre-defined operators 4213 (i.e., result 0). */ 4214 4215static int 4216possible_user_operator_p (enum exp_opcode op, struct value *args[]) 4217{ 4218 struct type *type0 = 4219 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0])); 4220 struct type *type1 = 4221 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1])); 4222 4223 if (type0 == NULL) 4224 return 0; 4225 4226 switch (op) 4227 { 4228 default: 4229 return 0; 4230 4231 case BINOP_ADD: 4232 case BINOP_SUB: 4233 case BINOP_MUL: 4234 case BINOP_DIV: 4235 return (!(numeric_type_p (type0) && numeric_type_p (type1))); 4236 4237 case BINOP_REM: 4238 case BINOP_MOD: 4239 case BINOP_BITWISE_AND: 4240 case BINOP_BITWISE_IOR: 4241 case BINOP_BITWISE_XOR: 4242 return (!(integer_type_p (type0) && integer_type_p (type1))); 4243 4244 case BINOP_EQUAL: 4245 case BINOP_NOTEQUAL: 4246 case BINOP_LESS: 4247 case BINOP_GTR: 4248 case BINOP_LEQ: 4249 case BINOP_GEQ: 4250 return (!(scalar_type_p (type0) && scalar_type_p (type1))); 4251 4252 case BINOP_CONCAT: 4253 return !ada_is_array_type (type0) || !ada_is_array_type (type1); 4254 4255 case BINOP_EXP: 4256 return (!(numeric_type_p (type0) && integer_type_p (type1))); 4257 4258 case UNOP_NEG: 4259 case UNOP_PLUS: 4260 case UNOP_LOGICAL_NOT: 4261 case UNOP_ABS: 4262 return (!numeric_type_p (type0)); 4263 4264 } 4265} 4266 4267 /* Renaming */ 4268 4269/* NOTES: 4270 4271 1. In the following, we assume that a renaming type's name may 4272 have an ___XD suffix. It would be nice if this went away at some 4273 point. 4274 2. We handle both the (old) purely type-based representation of 4275 renamings and the (new) variable-based encoding. At some point, 4276 it is devoutly to be hoped that the former goes away 4277 (FIXME: hilfinger-2007-07-09). 4278 3. Subprogram renamings are not implemented, although the XRS 4279 suffix is recognized (FIXME: hilfinger-2007-07-09). */ 4280 4281/* If SYM encodes a renaming, 4282 4283 <renaming> renames <renamed entity>, 4284 4285 sets *LEN to the length of the renamed entity's name, 4286 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to 4287 the string describing the subcomponent selected from the renamed 4288 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming 4289 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR 4290 are undefined). Otherwise, returns a value indicating the category 4291 of entity renamed: an object (ADA_OBJECT_RENAMING), exception 4292 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or 4293 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the 4294 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be 4295 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR 4296 may be NULL, in which case they are not assigned. 4297 4298 [Currently, however, GCC does not generate subprogram renamings.] */ 4299 4300enum ada_renaming_category 4301ada_parse_renaming (struct symbol *sym, 4302 const char **renamed_entity, int *len, 4303 const char **renaming_expr) 4304{ 4305 enum ada_renaming_category kind; 4306 const char *info; 4307 const char *suffix; 4308 4309 if (sym == NULL) 4310 return ADA_NOT_RENAMING; 4311 switch (SYMBOL_CLASS (sym)) 4312 { 4313 default: 4314 return ADA_NOT_RENAMING; 4315 case LOC_TYPEDEF: 4316 return parse_old_style_renaming (SYMBOL_TYPE (sym), 4317 renamed_entity, len, renaming_expr); 4318 case LOC_LOCAL: 4319 case LOC_STATIC: 4320 case LOC_COMPUTED: 4321 case LOC_OPTIMIZED_OUT: 4322 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR"); 4323 if (info == NULL) 4324 return ADA_NOT_RENAMING; 4325 switch (info[5]) 4326 { 4327 case '_': 4328 kind = ADA_OBJECT_RENAMING; 4329 info += 6; 4330 break; 4331 case 'E': 4332 kind = ADA_EXCEPTION_RENAMING; 4333 info += 7; 4334 break; 4335 case 'P': 4336 kind = ADA_PACKAGE_RENAMING; 4337 info += 7; 4338 break; 4339 case 'S': 4340 kind = ADA_SUBPROGRAM_RENAMING; 4341 info += 7; 4342 break; 4343 default: 4344 return ADA_NOT_RENAMING; 4345 } 4346 } 4347 4348 if (renamed_entity != NULL) 4349 *renamed_entity = info; 4350 suffix = strstr (info, "___XE"); 4351 if (suffix == NULL || suffix == info) 4352 return ADA_NOT_RENAMING; 4353 if (len != NULL) 4354 *len = strlen (info) - strlen (suffix); 4355 suffix += 5; 4356 if (renaming_expr != NULL) 4357 *renaming_expr = suffix; 4358 return kind; 4359} 4360 4361/* Assuming TYPE encodes a renaming according to the old encoding in 4362 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY, 4363 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns 4364 ADA_NOT_RENAMING otherwise. */ 4365static enum ada_renaming_category 4366parse_old_style_renaming (struct type *type, 4367 const char **renamed_entity, int *len, 4368 const char **renaming_expr) 4369{ 4370 enum ada_renaming_category kind; 4371 const char *name; 4372 const char *info; 4373 const char *suffix; 4374 4375 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM 4376 || TYPE_NFIELDS (type) != 1) 4377 return ADA_NOT_RENAMING; 4378 4379 name = TYPE_NAME (type); 4380 if (name == NULL) 4381 return ADA_NOT_RENAMING; 4382 4383 name = strstr (name, "___XR"); 4384 if (name == NULL) 4385 return ADA_NOT_RENAMING; 4386 switch (name[5]) 4387 { 4388 case '\0': 4389 case '_': 4390 kind = ADA_OBJECT_RENAMING; 4391 break; 4392 case 'E': 4393 kind = ADA_EXCEPTION_RENAMING; 4394 break; 4395 case 'P': 4396 kind = ADA_PACKAGE_RENAMING; 4397 break; 4398 case 'S': 4399 kind = ADA_SUBPROGRAM_RENAMING; 4400 break; 4401 default: 4402 return ADA_NOT_RENAMING; 4403 } 4404 4405 info = TYPE_FIELD_NAME (type, 0); 4406 if (info == NULL) 4407 return ADA_NOT_RENAMING; 4408 if (renamed_entity != NULL) 4409 *renamed_entity = info; 4410 suffix = strstr (info, "___XE"); 4411 if (renaming_expr != NULL) 4412 *renaming_expr = suffix + 5; 4413 if (suffix == NULL || suffix == info) 4414 return ADA_NOT_RENAMING; 4415 if (len != NULL) 4416 *len = suffix - info; 4417 return kind; 4418} 4419 4420/* Compute the value of the given RENAMING_SYM, which is expected to 4421 be a symbol encoding a renaming expression. BLOCK is the block 4422 used to evaluate the renaming. */ 4423 4424static struct value * 4425ada_read_renaming_var_value (struct symbol *renaming_sym, 4426 const struct block *block) 4427{ 4428 const char *sym_name; 4429 4430 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym); 4431 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0); 4432 return evaluate_expression (expr.get ()); 4433} 4434 4435 4436 /* Evaluation: Function Calls */ 4437 4438/* Return an lvalue containing the value VAL. This is the identity on 4439 lvalues, and otherwise has the side-effect of allocating memory 4440 in the inferior where a copy of the value contents is copied. */ 4441 4442static struct value * 4443ensure_lval (struct value *val) 4444{ 4445 if (VALUE_LVAL (val) == not_lval 4446 || VALUE_LVAL (val) == lval_internalvar) 4447 { 4448 int len = TYPE_LENGTH (ada_check_typedef (value_type (val))); 4449 const CORE_ADDR addr = 4450 value_as_long (value_allocate_space_in_inferior (len)); 4451 4452 VALUE_LVAL (val) = lval_memory; 4453 set_value_address (val, addr); 4454 write_memory (addr, value_contents (val), len); 4455 } 4456 4457 return val; 4458} 4459 4460/* Return the value ACTUAL, converted to be an appropriate value for a 4461 formal of type FORMAL_TYPE. Use *SP as a stack pointer for 4462 allocating any necessary descriptors (fat pointers), or copies of 4463 values not residing in memory, updating it as needed. */ 4464 4465struct value * 4466ada_convert_actual (struct value *actual, struct type *formal_type0) 4467{ 4468 struct type *actual_type = ada_check_typedef (value_type (actual)); 4469 struct type *formal_type = ada_check_typedef (formal_type0); 4470 struct type *formal_target = 4471 TYPE_CODE (formal_type) == TYPE_CODE_PTR 4472 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type; 4473 struct type *actual_target = 4474 TYPE_CODE (actual_type) == TYPE_CODE_PTR 4475 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type; 4476 4477 if (ada_is_array_descriptor_type (formal_target) 4478 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY) 4479 return make_array_descriptor (formal_type, actual); 4480 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR 4481 || TYPE_CODE (formal_type) == TYPE_CODE_REF) 4482 { 4483 struct value *result; 4484 4485 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY 4486 && ada_is_array_descriptor_type (actual_target)) 4487 result = desc_data (actual); 4488 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR) 4489 { 4490 if (VALUE_LVAL (actual) != lval_memory) 4491 { 4492 struct value *val; 4493 4494 actual_type = ada_check_typedef (value_type (actual)); 4495 val = allocate_value (actual_type); 4496 memcpy ((char *) value_contents_raw (val), 4497 (char *) value_contents (actual), 4498 TYPE_LENGTH (actual_type)); 4499 actual = ensure_lval (val); 4500 } 4501 result = value_addr (actual); 4502 } 4503 else 4504 return actual; 4505 return value_cast_pointers (formal_type, result, 0); 4506 } 4507 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR) 4508 return ada_value_ind (actual); 4509 else if (ada_is_aligner_type (formal_type)) 4510 { 4511 /* We need to turn this parameter into an aligner type 4512 as well. */ 4513 struct value *aligner = allocate_value (formal_type); 4514 struct value *component = ada_value_struct_elt (aligner, "F", 0); 4515 4516 value_assign_to_component (aligner, component, actual); 4517 return aligner; 4518 } 4519 4520 return actual; 4521} 4522 4523/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of 4524 type TYPE. This is usually an inefficient no-op except on some targets 4525 (such as AVR) where the representation of a pointer and an address 4526 differs. */ 4527 4528static CORE_ADDR 4529value_pointer (struct value *value, struct type *type) 4530{ 4531 struct gdbarch *gdbarch = get_type_arch (type); 4532 unsigned len = TYPE_LENGTH (type); 4533 gdb_byte *buf = (gdb_byte *) alloca (len); 4534 CORE_ADDR addr; 4535 4536 addr = value_address (value); 4537 gdbarch_address_to_pointer (gdbarch, type, buf, addr); 4538 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch)); 4539 return addr; 4540} 4541 4542 4543/* Push a descriptor of type TYPE for array value ARR on the stack at 4544 *SP, updating *SP to reflect the new descriptor. Return either 4545 an lvalue representing the new descriptor, or (if TYPE is a pointer- 4546 to-descriptor type rather than a descriptor type), a struct value * 4547 representing a pointer to this descriptor. */ 4548 4549static struct value * 4550make_array_descriptor (struct type *type, struct value *arr) 4551{ 4552 struct type *bounds_type = desc_bounds_type (type); 4553 struct type *desc_type = desc_base_type (type); 4554 struct value *descriptor = allocate_value (desc_type); 4555 struct value *bounds = allocate_value (bounds_type); 4556 int i; 4557 4558 for (i = ada_array_arity (ada_check_typedef (value_type (arr))); 4559 i > 0; i -= 1) 4560 { 4561 modify_field (value_type (bounds), value_contents_writeable (bounds), 4562 ada_array_bound (arr, i, 0), 4563 desc_bound_bitpos (bounds_type, i, 0), 4564 desc_bound_bitsize (bounds_type, i, 0)); 4565 modify_field (value_type (bounds), value_contents_writeable (bounds), 4566 ada_array_bound (arr, i, 1), 4567 desc_bound_bitpos (bounds_type, i, 1), 4568 desc_bound_bitsize (bounds_type, i, 1)); 4569 } 4570 4571 bounds = ensure_lval (bounds); 4572 4573 modify_field (value_type (descriptor), 4574 value_contents_writeable (descriptor), 4575 value_pointer (ensure_lval (arr), 4576 TYPE_FIELD_TYPE (desc_type, 0)), 4577 fat_pntr_data_bitpos (desc_type), 4578 fat_pntr_data_bitsize (desc_type)); 4579 4580 modify_field (value_type (descriptor), 4581 value_contents_writeable (descriptor), 4582 value_pointer (bounds, 4583 TYPE_FIELD_TYPE (desc_type, 1)), 4584 fat_pntr_bounds_bitpos (desc_type), 4585 fat_pntr_bounds_bitsize (desc_type)); 4586 4587 descriptor = ensure_lval (descriptor); 4588 4589 if (TYPE_CODE (type) == TYPE_CODE_PTR) 4590 return value_addr (descriptor); 4591 else 4592 return descriptor; 4593} 4594 4595 /* Symbol Cache Module */ 4596 4597/* Performance measurements made as of 2010-01-15 indicate that 4598 this cache does bring some noticeable improvements. Depending 4599 on the type of entity being printed, the cache can make it as much 4600 as an order of magnitude faster than without it. 4601 4602 The descriptive type DWARF extension has significantly reduced 4603 the need for this cache, at least when DWARF is being used. However, 4604 even in this case, some expensive name-based symbol searches are still 4605 sometimes necessary - to find an XVZ variable, mostly. */ 4606 4607/* Initialize the contents of SYM_CACHE. */ 4608 4609static void 4610ada_init_symbol_cache (struct ada_symbol_cache *sym_cache) 4611{ 4612 obstack_init (&sym_cache->cache_space); 4613 memset (sym_cache->root, '\000', sizeof (sym_cache->root)); 4614} 4615 4616/* Free the memory used by SYM_CACHE. */ 4617 4618static void 4619ada_free_symbol_cache (struct ada_symbol_cache *sym_cache) 4620{ 4621 obstack_free (&sym_cache->cache_space, NULL); 4622 xfree (sym_cache); 4623} 4624 4625/* Return the symbol cache associated to the given program space PSPACE. 4626 If not allocated for this PSPACE yet, allocate and initialize one. */ 4627 4628static struct ada_symbol_cache * 4629ada_get_symbol_cache (struct program_space *pspace) 4630{ 4631 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace); 4632 4633 if (pspace_data->sym_cache == NULL) 4634 { 4635 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache); 4636 ada_init_symbol_cache (pspace_data->sym_cache); 4637 } 4638 4639 return pspace_data->sym_cache; 4640} 4641 4642/* Clear all entries from the symbol cache. */ 4643 4644static void 4645ada_clear_symbol_cache (void) 4646{ 4647 struct ada_symbol_cache *sym_cache 4648 = ada_get_symbol_cache (current_program_space); 4649 4650 obstack_free (&sym_cache->cache_space, NULL); 4651 ada_init_symbol_cache (sym_cache); 4652} 4653 4654/* Search our cache for an entry matching NAME and DOMAIN. 4655 Return it if found, or NULL otherwise. */ 4656 4657static struct cache_entry ** 4658find_entry (const char *name, domain_enum domain) 4659{ 4660 struct ada_symbol_cache *sym_cache 4661 = ada_get_symbol_cache (current_program_space); 4662 int h = msymbol_hash (name) % HASH_SIZE; 4663 struct cache_entry **e; 4664 4665 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next) 4666 { 4667 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0) 4668 return e; 4669 } 4670 return NULL; 4671} 4672 4673/* Search the symbol cache for an entry matching NAME and DOMAIN. 4674 Return 1 if found, 0 otherwise. 4675 4676 If an entry was found and SYM is not NULL, set *SYM to the entry's 4677 SYM. Same principle for BLOCK if not NULL. */ 4678 4679static int 4680lookup_cached_symbol (const char *name, domain_enum domain, 4681 struct symbol **sym, const struct block **block) 4682{ 4683 struct cache_entry **e = find_entry (name, domain); 4684 4685 if (e == NULL) 4686 return 0; 4687 if (sym != NULL) 4688 *sym = (*e)->sym; 4689 if (block != NULL) 4690 *block = (*e)->block; 4691 return 1; 4692} 4693 4694/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME 4695 in domain DOMAIN, save this result in our symbol cache. */ 4696 4697static void 4698cache_symbol (const char *name, domain_enum domain, struct symbol *sym, 4699 const struct block *block) 4700{ 4701 struct ada_symbol_cache *sym_cache 4702 = ada_get_symbol_cache (current_program_space); 4703 int h; 4704 char *copy; 4705 struct cache_entry *e; 4706 4707 /* Symbols for builtin types don't have a block. 4708 For now don't cache such symbols. */ 4709 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym)) 4710 return; 4711 4712 /* If the symbol is a local symbol, then do not cache it, as a search 4713 for that symbol depends on the context. To determine whether 4714 the symbol is local or not, we check the block where we found it 4715 against the global and static blocks of its associated symtab. */ 4716 if (sym 4717 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)), 4718 GLOBAL_BLOCK) != block 4719 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)), 4720 STATIC_BLOCK) != block) 4721 return; 4722 4723 h = msymbol_hash (name) % HASH_SIZE; 4724 e = XOBNEW (&sym_cache->cache_space, cache_entry); 4725 e->next = sym_cache->root[h]; 4726 sym_cache->root[h] = e; 4727 e->name = copy 4728 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1); 4729 strcpy (copy, name); 4730 e->sym = sym; 4731 e->domain = domain; 4732 e->block = block; 4733} 4734 4735 /* Symbol Lookup */ 4736 4737/* Return the symbol name match type that should be used used when 4738 searching for all symbols matching LOOKUP_NAME. 4739 4740 LOOKUP_NAME is expected to be a symbol name after transformation 4741 for Ada lookups. */ 4742 4743static symbol_name_match_type 4744name_match_type_from_name (const char *lookup_name) 4745{ 4746 return (strstr (lookup_name, "__") == NULL 4747 ? symbol_name_match_type::WILD 4748 : symbol_name_match_type::FULL); 4749} 4750 4751/* Return the result of a standard (literal, C-like) lookup of NAME in 4752 given DOMAIN, visible from lexical block BLOCK. */ 4753 4754static struct symbol * 4755standard_lookup (const char *name, const struct block *block, 4756 domain_enum domain) 4757{ 4758 /* Initialize it just to avoid a GCC false warning. */ 4759 struct block_symbol sym = {NULL, NULL}; 4760 4761 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL)) 4762 return sym.symbol; 4763 ada_lookup_encoded_symbol (name, block, domain, &sym); 4764 cache_symbol (name, domain, sym.symbol, sym.block); 4765 return sym.symbol; 4766} 4767 4768 4769/* Non-zero iff there is at least one non-function/non-enumeral symbol 4770 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions, 4771 since they contend in overloading in the same way. */ 4772static int 4773is_nonfunction (struct block_symbol syms[], int n) 4774{ 4775 int i; 4776 4777 for (i = 0; i < n; i += 1) 4778 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC 4779 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM 4780 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST)) 4781 return 1; 4782 4783 return 0; 4784} 4785 4786/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent 4787 struct types. Otherwise, they may not. */ 4788 4789static int 4790equiv_types (struct type *type0, struct type *type1) 4791{ 4792 if (type0 == type1) 4793 return 1; 4794 if (type0 == NULL || type1 == NULL 4795 || TYPE_CODE (type0) != TYPE_CODE (type1)) 4796 return 0; 4797 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT 4798 || TYPE_CODE (type0) == TYPE_CODE_ENUM) 4799 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL 4800 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0) 4801 return 1; 4802 4803 return 0; 4804} 4805 4806/* True iff SYM0 represents the same entity as SYM1, or one that is 4807 no more defined than that of SYM1. */ 4808 4809static int 4810lesseq_defined_than (struct symbol *sym0, struct symbol *sym1) 4811{ 4812 if (sym0 == sym1) 4813 return 1; 4814 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1) 4815 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1)) 4816 return 0; 4817 4818 switch (SYMBOL_CLASS (sym0)) 4819 { 4820 case LOC_UNDEF: 4821 return 1; 4822 case LOC_TYPEDEF: 4823 { 4824 struct type *type0 = SYMBOL_TYPE (sym0); 4825 struct type *type1 = SYMBOL_TYPE (sym1); 4826 const char *name0 = SYMBOL_LINKAGE_NAME (sym0); 4827 const char *name1 = SYMBOL_LINKAGE_NAME (sym1); 4828 int len0 = strlen (name0); 4829 4830 return 4831 TYPE_CODE (type0) == TYPE_CODE (type1) 4832 && (equiv_types (type0, type1) 4833 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0 4834 && startswith (name1 + len0, "___XV"))); 4835 } 4836 case LOC_CONST: 4837 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1) 4838 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1)); 4839 default: 4840 return 0; 4841 } 4842} 4843 4844/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol 4845 records in OBSTACKP. Do nothing if SYM is a duplicate. */ 4846 4847static void 4848add_defn_to_vec (struct obstack *obstackp, 4849 struct symbol *sym, 4850 const struct block *block) 4851{ 4852 int i; 4853 struct block_symbol *prevDefns = defns_collected (obstackp, 0); 4854 4855 /* Do not try to complete stub types, as the debugger is probably 4856 already scanning all symbols matching a certain name at the 4857 time when this function is called. Trying to replace the stub 4858 type by its associated full type will cause us to restart a scan 4859 which may lead to an infinite recursion. Instead, the client 4860 collecting the matching symbols will end up collecting several 4861 matches, with at least one of them complete. It can then filter 4862 out the stub ones if needed. */ 4863 4864 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1) 4865 { 4866 if (lesseq_defined_than (sym, prevDefns[i].symbol)) 4867 return; 4868 else if (lesseq_defined_than (prevDefns[i].symbol, sym)) 4869 { 4870 prevDefns[i].symbol = sym; 4871 prevDefns[i].block = block; 4872 return; 4873 } 4874 } 4875 4876 { 4877 struct block_symbol info; 4878 4879 info.symbol = sym; 4880 info.block = block; 4881 obstack_grow (obstackp, &info, sizeof (struct block_symbol)); 4882 } 4883} 4884 4885/* Number of block_symbol structures currently collected in current vector in 4886 OBSTACKP. */ 4887 4888static int 4889num_defns_collected (struct obstack *obstackp) 4890{ 4891 return obstack_object_size (obstackp) / sizeof (struct block_symbol); 4892} 4893 4894/* Vector of block_symbol structures currently collected in current vector in 4895 OBSTACKP. If FINISH, close off the vector and return its final address. */ 4896 4897static struct block_symbol * 4898defns_collected (struct obstack *obstackp, int finish) 4899{ 4900 if (finish) 4901 return (struct block_symbol *) obstack_finish (obstackp); 4902 else 4903 return (struct block_symbol *) obstack_base (obstackp); 4904} 4905 4906/* Return a bound minimal symbol matching NAME according to Ada 4907 decoding rules. Returns an invalid symbol if there is no such 4908 minimal symbol. Names prefixed with "standard__" are handled 4909 specially: "standard__" is first stripped off, and only static and 4910 global symbols are searched. */ 4911 4912struct bound_minimal_symbol 4913ada_lookup_simple_minsym (const char *name) 4914{ 4915 struct bound_minimal_symbol result; 4916 4917 memset (&result, 0, sizeof (result)); 4918 4919 symbol_name_match_type match_type = name_match_type_from_name (name); 4920 lookup_name_info lookup_name (name, match_type); 4921 4922 symbol_name_matcher_ftype *match_name 4923 = ada_get_symbol_name_matcher (lookup_name); 4924 4925 for (objfile *objfile : current_program_space->objfiles ()) 4926 { 4927 for (minimal_symbol *msymbol : objfile->msymbols ()) 4928 { 4929 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL) 4930 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline) 4931 { 4932 result.minsym = msymbol; 4933 result.objfile = objfile; 4934 break; 4935 } 4936 } 4937 } 4938 4939 return result; 4940} 4941 4942/* For all subprograms that statically enclose the subprogram of the 4943 selected frame, add symbols matching identifier NAME in DOMAIN 4944 and their blocks to the list of data in OBSTACKP, as for 4945 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME 4946 with a wildcard prefix. */ 4947 4948static void 4949add_symbols_from_enclosing_procs (struct obstack *obstackp, 4950 const lookup_name_info &lookup_name, 4951 domain_enum domain) 4952{ 4953} 4954 4955/* True if TYPE is definitely an artificial type supplied to a symbol 4956 for which no debugging information was given in the symbol file. */ 4957 4958static int 4959is_nondebugging_type (struct type *type) 4960{ 4961 const char *name = ada_type_name (type); 4962 4963 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0); 4964} 4965 4966/* Return nonzero if TYPE1 and TYPE2 are two enumeration types 4967 that are deemed "identical" for practical purposes. 4968 4969 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM 4970 types and that their number of enumerals is identical (in other 4971 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */ 4972 4973static int 4974ada_identical_enum_types_p (struct type *type1, struct type *type2) 4975{ 4976 int i; 4977 4978 /* The heuristic we use here is fairly conservative. We consider 4979 that 2 enumerate types are identical if they have the same 4980 number of enumerals and that all enumerals have the same 4981 underlying value and name. */ 4982 4983 /* All enums in the type should have an identical underlying value. */ 4984 for (i = 0; i < TYPE_NFIELDS (type1); i++) 4985 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i)) 4986 return 0; 4987 4988 /* All enumerals should also have the same name (modulo any numerical 4989 suffix). */ 4990 for (i = 0; i < TYPE_NFIELDS (type1); i++) 4991 { 4992 const char *name_1 = TYPE_FIELD_NAME (type1, i); 4993 const char *name_2 = TYPE_FIELD_NAME (type2, i); 4994 int len_1 = strlen (name_1); 4995 int len_2 = strlen (name_2); 4996 4997 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1); 4998 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2); 4999 if (len_1 != len_2 5000 || strncmp (TYPE_FIELD_NAME (type1, i), 5001 TYPE_FIELD_NAME (type2, i), 5002 len_1) != 0) 5003 return 0; 5004 } 5005 5006 return 1; 5007} 5008 5009/* Return nonzero if all the symbols in SYMS are all enumeral symbols 5010 that are deemed "identical" for practical purposes. Sometimes, 5011 enumerals are not strictly identical, but their types are so similar 5012 that they can be considered identical. 5013 5014 For instance, consider the following code: 5015 5016 type Color is (Black, Red, Green, Blue, White); 5017 type RGB_Color is new Color range Red .. Blue; 5018 5019 Type RGB_Color is a subrange of an implicit type which is a copy 5020 of type Color. If we call that implicit type RGB_ColorB ("B" is 5021 for "Base Type"), then type RGB_ColorB is a copy of type Color. 5022 As a result, when an expression references any of the enumeral 5023 by name (Eg. "print green"), the expression is technically 5024 ambiguous and the user should be asked to disambiguate. But 5025 doing so would only hinder the user, since it wouldn't matter 5026 what choice he makes, the outcome would always be the same. 5027 So, for practical purposes, we consider them as the same. */ 5028 5029static int 5030symbols_are_identical_enums (const std::vector<struct block_symbol> &syms) 5031{ 5032 int i; 5033 5034 /* Before performing a thorough comparison check of each type, 5035 we perform a series of inexpensive checks. We expect that these 5036 checks will quickly fail in the vast majority of cases, and thus 5037 help prevent the unnecessary use of a more expensive comparison. 5038 Said comparison also expects us to make some of these checks 5039 (see ada_identical_enum_types_p). */ 5040 5041 /* Quick check: All symbols should have an enum type. */ 5042 for (i = 0; i < syms.size (); i++) 5043 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM) 5044 return 0; 5045 5046 /* Quick check: They should all have the same value. */ 5047 for (i = 1; i < syms.size (); i++) 5048 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol)) 5049 return 0; 5050 5051 /* Quick check: They should all have the same number of enumerals. */ 5052 for (i = 1; i < syms.size (); i++) 5053 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol)) 5054 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol))) 5055 return 0; 5056 5057 /* All the sanity checks passed, so we might have a set of 5058 identical enumeration types. Perform a more complete 5059 comparison of the type of each symbol. */ 5060 for (i = 1; i < syms.size (); i++) 5061 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol), 5062 SYMBOL_TYPE (syms[0].symbol))) 5063 return 0; 5064 5065 return 1; 5066} 5067 5068/* Remove any non-debugging symbols in SYMS that definitely 5069 duplicate other symbols in the list (The only case I know of where 5070 this happens is when object files containing stabs-in-ecoff are 5071 linked with files containing ordinary ecoff debugging symbols (or no 5072 debugging symbols)). Modifies SYMS to squeeze out deleted entries. 5073 Returns the number of items in the modified list. */ 5074 5075static int 5076remove_extra_symbols (std::vector<struct block_symbol> *syms) 5077{ 5078 int i, j; 5079 5080 /* We should never be called with less than 2 symbols, as there 5081 cannot be any extra symbol in that case. But it's easy to 5082 handle, since we have nothing to do in that case. */ 5083 if (syms->size () < 2) 5084 return syms->size (); 5085 5086 i = 0; 5087 while (i < syms->size ()) 5088 { 5089 int remove_p = 0; 5090 5091 /* If two symbols have the same name and one of them is a stub type, 5092 the get rid of the stub. */ 5093 5094 if (TYPE_STUB (SYMBOL_TYPE ((*syms)[i].symbol)) 5095 && SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL) 5096 { 5097 for (j = 0; j < syms->size (); j++) 5098 { 5099 if (j != i 5100 && !TYPE_STUB (SYMBOL_TYPE ((*syms)[j].symbol)) 5101 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL 5102 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol), 5103 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0) 5104 remove_p = 1; 5105 } 5106 } 5107 5108 /* Two symbols with the same name, same class and same address 5109 should be identical. */ 5110 5111 else if (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol) != NULL 5112 && SYMBOL_CLASS ((*syms)[i].symbol) == LOC_STATIC 5113 && is_nondebugging_type (SYMBOL_TYPE ((*syms)[i].symbol))) 5114 { 5115 for (j = 0; j < syms->size (); j += 1) 5116 { 5117 if (i != j 5118 && SYMBOL_LINKAGE_NAME ((*syms)[j].symbol) != NULL 5119 && strcmp (SYMBOL_LINKAGE_NAME ((*syms)[i].symbol), 5120 SYMBOL_LINKAGE_NAME ((*syms)[j].symbol)) == 0 5121 && SYMBOL_CLASS ((*syms)[i].symbol) 5122 == SYMBOL_CLASS ((*syms)[j].symbol) 5123 && SYMBOL_VALUE_ADDRESS ((*syms)[i].symbol) 5124 == SYMBOL_VALUE_ADDRESS ((*syms)[j].symbol)) 5125 remove_p = 1; 5126 } 5127 } 5128 5129 if (remove_p) 5130 syms->erase (syms->begin () + i); 5131 5132 i += 1; 5133 } 5134 5135 /* If all the remaining symbols are identical enumerals, then 5136 just keep the first one and discard the rest. 5137 5138 Unlike what we did previously, we do not discard any entry 5139 unless they are ALL identical. This is because the symbol 5140 comparison is not a strict comparison, but rather a practical 5141 comparison. If all symbols are considered identical, then 5142 we can just go ahead and use the first one and discard the rest. 5143 But if we cannot reduce the list to a single element, we have 5144 to ask the user to disambiguate anyways. And if we have to 5145 present a multiple-choice menu, it's less confusing if the list 5146 isn't missing some choices that were identical and yet distinct. */ 5147 if (symbols_are_identical_enums (*syms)) 5148 syms->resize (1); 5149 5150 return syms->size (); 5151} 5152 5153/* Given a type that corresponds to a renaming entity, use the type name 5154 to extract the scope (package name or function name, fully qualified, 5155 and following the GNAT encoding convention) where this renaming has been 5156 defined. */ 5157 5158static std::string 5159xget_renaming_scope (struct type *renaming_type) 5160{ 5161 /* The renaming types adhere to the following convention: 5162 <scope>__<rename>___<XR extension>. 5163 So, to extract the scope, we search for the "___XR" extension, 5164 and then backtrack until we find the first "__". */ 5165 5166 const char *name = TYPE_NAME (renaming_type); 5167 const char *suffix = strstr (name, "___XR"); 5168 const char *last; 5169 5170 /* Now, backtrack a bit until we find the first "__". Start looking 5171 at suffix - 3, as the <rename> part is at least one character long. */ 5172 5173 for (last = suffix - 3; last > name; last--) 5174 if (last[0] == '_' && last[1] == '_') 5175 break; 5176 5177 /* Make a copy of scope and return it. */ 5178 return std::string (name, last); 5179} 5180 5181/* Return nonzero if NAME corresponds to a package name. */ 5182 5183static int 5184is_package_name (const char *name) 5185{ 5186 /* Here, We take advantage of the fact that no symbols are generated 5187 for packages, while symbols are generated for each function. 5188 So the condition for NAME represent a package becomes equivalent 5189 to NAME not existing in our list of symbols. There is only one 5190 small complication with library-level functions (see below). */ 5191 5192 /* If it is a function that has not been defined at library level, 5193 then we should be able to look it up in the symbols. */ 5194 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL) 5195 return 0; 5196 5197 /* Library-level function names start with "_ada_". See if function 5198 "_ada_" followed by NAME can be found. */ 5199 5200 /* Do a quick check that NAME does not contain "__", since library-level 5201 functions names cannot contain "__" in them. */ 5202 if (strstr (name, "__") != NULL) 5203 return 0; 5204 5205 std::string fun_name = string_printf ("_ada_%s", name); 5206 5207 return (standard_lookup (fun_name.c_str (), NULL, VAR_DOMAIN) == NULL); 5208} 5209 5210/* Return nonzero if SYM corresponds to a renaming entity that is 5211 not visible from FUNCTION_NAME. */ 5212 5213static int 5214old_renaming_is_invisible (const struct symbol *sym, const char *function_name) 5215{ 5216 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF) 5217 return 0; 5218 5219 std::string scope = xget_renaming_scope (SYMBOL_TYPE (sym)); 5220 5221 /* If the rename has been defined in a package, then it is visible. */ 5222 if (is_package_name (scope.c_str ())) 5223 return 0; 5224 5225 /* Check that the rename is in the current function scope by checking 5226 that its name starts with SCOPE. */ 5227 5228 /* If the function name starts with "_ada_", it means that it is 5229 a library-level function. Strip this prefix before doing the 5230 comparison, as the encoding for the renaming does not contain 5231 this prefix. */ 5232 if (startswith (function_name, "_ada_")) 5233 function_name += 5; 5234 5235 return !startswith (function_name, scope.c_str ()); 5236} 5237 5238/* Remove entries from SYMS that corresponds to a renaming entity that 5239 is not visible from the function associated with CURRENT_BLOCK or 5240 that is superfluous due to the presence of more specific renaming 5241 information. Places surviving symbols in the initial entries of 5242 SYMS and returns the number of surviving symbols. 5243 5244 Rationale: 5245 First, in cases where an object renaming is implemented as a 5246 reference variable, GNAT may produce both the actual reference 5247 variable and the renaming encoding. In this case, we discard the 5248 latter. 5249 5250 Second, GNAT emits a type following a specified encoding for each renaming 5251 entity. Unfortunately, STABS currently does not support the definition 5252 of types that are local to a given lexical block, so all renamings types 5253 are emitted at library level. As a consequence, if an application 5254 contains two renaming entities using the same name, and a user tries to 5255 print the value of one of these entities, the result of the ada symbol 5256 lookup will also contain the wrong renaming type. 5257 5258 This function partially covers for this limitation by attempting to 5259 remove from the SYMS list renaming symbols that should be visible 5260 from CURRENT_BLOCK. However, there does not seem be a 100% reliable 5261 method with the current information available. The implementation 5262 below has a couple of limitations (FIXME: brobecker-2003-05-12): 5263 5264 - When the user tries to print a rename in a function while there 5265 is another rename entity defined in a package: Normally, the 5266 rename in the function has precedence over the rename in the 5267 package, so the latter should be removed from the list. This is 5268 currently not the case. 5269 5270 - This function will incorrectly remove valid renames if 5271 the CURRENT_BLOCK corresponds to a function which symbol name 5272 has been changed by an "Export" pragma. As a consequence, 5273 the user will be unable to print such rename entities. */ 5274 5275static int 5276remove_irrelevant_renamings (std::vector<struct block_symbol> *syms, 5277 const struct block *current_block) 5278{ 5279 struct symbol *current_function; 5280 const char *current_function_name; 5281 int i; 5282 int is_new_style_renaming; 5283 5284 /* If there is both a renaming foo___XR... encoded as a variable and 5285 a simple variable foo in the same block, discard the latter. 5286 First, zero out such symbols, then compress. */ 5287 is_new_style_renaming = 0; 5288 for (i = 0; i < syms->size (); i += 1) 5289 { 5290 struct symbol *sym = (*syms)[i].symbol; 5291 const struct block *block = (*syms)[i].block; 5292 const char *name; 5293 const char *suffix; 5294 5295 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF) 5296 continue; 5297 name = SYMBOL_LINKAGE_NAME (sym); 5298 suffix = strstr (name, "___XR"); 5299 5300 if (suffix != NULL) 5301 { 5302 int name_len = suffix - name; 5303 int j; 5304 5305 is_new_style_renaming = 1; 5306 for (j = 0; j < syms->size (); j += 1) 5307 if (i != j && (*syms)[j].symbol != NULL 5308 && strncmp (name, SYMBOL_LINKAGE_NAME ((*syms)[j].symbol), 5309 name_len) == 0 5310 && block == (*syms)[j].block) 5311 (*syms)[j].symbol = NULL; 5312 } 5313 } 5314 if (is_new_style_renaming) 5315 { 5316 int j, k; 5317 5318 for (j = k = 0; j < syms->size (); j += 1) 5319 if ((*syms)[j].symbol != NULL) 5320 { 5321 (*syms)[k] = (*syms)[j]; 5322 k += 1; 5323 } 5324 return k; 5325 } 5326 5327 /* Extract the function name associated to CURRENT_BLOCK. 5328 Abort if unable to do so. */ 5329 5330 if (current_block == NULL) 5331 return syms->size (); 5332 5333 current_function = block_linkage_function (current_block); 5334 if (current_function == NULL) 5335 return syms->size (); 5336 5337 current_function_name = SYMBOL_LINKAGE_NAME (current_function); 5338 if (current_function_name == NULL) 5339 return syms->size (); 5340 5341 /* Check each of the symbols, and remove it from the list if it is 5342 a type corresponding to a renaming that is out of the scope of 5343 the current block. */ 5344 5345 i = 0; 5346 while (i < syms->size ()) 5347 { 5348 if (ada_parse_renaming ((*syms)[i].symbol, NULL, NULL, NULL) 5349 == ADA_OBJECT_RENAMING 5350 && old_renaming_is_invisible ((*syms)[i].symbol, 5351 current_function_name)) 5352 syms->erase (syms->begin () + i); 5353 else 5354 i += 1; 5355 } 5356 5357 return syms->size (); 5358} 5359 5360/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks) 5361 whose name and domain match NAME and DOMAIN respectively. 5362 If no match was found, then extend the search to "enclosing" 5363 routines (in other words, if we're inside a nested function, 5364 search the symbols defined inside the enclosing functions). 5365 If WILD_MATCH_P is nonzero, perform the naming matching in 5366 "wild" mode (see function "wild_match" for more info). 5367 5368 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */ 5369 5370static void 5371ada_add_local_symbols (struct obstack *obstackp, 5372 const lookup_name_info &lookup_name, 5373 const struct block *block, domain_enum domain) 5374{ 5375 int block_depth = 0; 5376 5377 while (block != NULL) 5378 { 5379 block_depth += 1; 5380 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL); 5381 5382 /* If we found a non-function match, assume that's the one. */ 5383 if (is_nonfunction (defns_collected (obstackp, 0), 5384 num_defns_collected (obstackp))) 5385 return; 5386 5387 block = BLOCK_SUPERBLOCK (block); 5388 } 5389 5390 /* If no luck so far, try to find NAME as a local symbol in some lexically 5391 enclosing subprogram. */ 5392 if (num_defns_collected (obstackp) == 0 && block_depth > 2) 5393 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain); 5394} 5395 5396/* An object of this type is used as the user_data argument when 5397 calling the map_matching_symbols method. */ 5398 5399struct match_data 5400{ 5401 struct objfile *objfile; 5402 struct obstack *obstackp; 5403 struct symbol *arg_sym; 5404 int found_sym; 5405}; 5406 5407/* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK, 5408 to a list of symbols. DATA0 is a pointer to a struct match_data * 5409 containing the obstack that collects the symbol list, the file that SYM 5410 must come from, a flag indicating whether a non-argument symbol has 5411 been found in the current block, and the last argument symbol 5412 passed in SYM within the current block (if any). When SYM is null, 5413 marking the end of a block, the argument symbol is added if no 5414 other has been found. */ 5415 5416static int 5417aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0) 5418{ 5419 struct match_data *data = (struct match_data *) data0; 5420 5421 if (sym == NULL) 5422 { 5423 if (!data->found_sym && data->arg_sym != NULL) 5424 add_defn_to_vec (data->obstackp, 5425 fixup_symbol_section (data->arg_sym, data->objfile), 5426 block); 5427 data->found_sym = 0; 5428 data->arg_sym = NULL; 5429 } 5430 else 5431 { 5432 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED) 5433 return 0; 5434 else if (SYMBOL_IS_ARGUMENT (sym)) 5435 data->arg_sym = sym; 5436 else 5437 { 5438 data->found_sym = 1; 5439 add_defn_to_vec (data->obstackp, 5440 fixup_symbol_section (sym, data->objfile), 5441 block); 5442 } 5443 } 5444 return 0; 5445} 5446 5447/* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are 5448 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these 5449 symbols to OBSTACKP. Return whether we found such symbols. */ 5450 5451static int 5452ada_add_block_renamings (struct obstack *obstackp, 5453 const struct block *block, 5454 const lookup_name_info &lookup_name, 5455 domain_enum domain) 5456{ 5457 struct using_direct *renaming; 5458 int defns_mark = num_defns_collected (obstackp); 5459 5460 symbol_name_matcher_ftype *name_match 5461 = ada_get_symbol_name_matcher (lookup_name); 5462 5463 for (renaming = block_using (block); 5464 renaming != NULL; 5465 renaming = renaming->next) 5466 { 5467 const char *r_name; 5468 5469 /* Avoid infinite recursions: skip this renaming if we are actually 5470 already traversing it. 5471 5472 Currently, symbol lookup in Ada don't use the namespace machinery from 5473 C++/Fortran support: skip namespace imports that use them. */ 5474 if (renaming->searched 5475 || (renaming->import_src != NULL 5476 && renaming->import_src[0] != '\0') 5477 || (renaming->import_dest != NULL 5478 && renaming->import_dest[0] != '\0')) 5479 continue; 5480 renaming->searched = 1; 5481 5482 /* TODO: here, we perform another name-based symbol lookup, which can 5483 pull its own multiple overloads. In theory, we should be able to do 5484 better in this case since, in DWARF, DW_AT_import is a DIE reference, 5485 not a simple name. But in order to do this, we would need to enhance 5486 the DWARF reader to associate a symbol to this renaming, instead of a 5487 name. So, for now, we do something simpler: re-use the C++/Fortran 5488 namespace machinery. */ 5489 r_name = (renaming->alias != NULL 5490 ? renaming->alias 5491 : renaming->declaration); 5492 if (name_match (r_name, lookup_name, NULL)) 5493 { 5494 lookup_name_info decl_lookup_name (renaming->declaration, 5495 lookup_name.match_type ()); 5496 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain, 5497 1, NULL); 5498 } 5499 renaming->searched = 0; 5500 } 5501 return num_defns_collected (obstackp) != defns_mark; 5502} 5503 5504/* Implements compare_names, but only applying the comparision using 5505 the given CASING. */ 5506 5507static int 5508compare_names_with_case (const char *string1, const char *string2, 5509 enum case_sensitivity casing) 5510{ 5511 while (*string1 != '\0' && *string2 != '\0') 5512 { 5513 char c1, c2; 5514 5515 if (isspace (*string1) || isspace (*string2)) 5516 return strcmp_iw_ordered (string1, string2); 5517 5518 if (casing == case_sensitive_off) 5519 { 5520 c1 = tolower (*string1); 5521 c2 = tolower (*string2); 5522 } 5523 else 5524 { 5525 c1 = *string1; 5526 c2 = *string2; 5527 } 5528 if (c1 != c2) 5529 break; 5530 5531 string1 += 1; 5532 string2 += 1; 5533 } 5534 5535 switch (*string1) 5536 { 5537 case '(': 5538 return strcmp_iw_ordered (string1, string2); 5539 case '_': 5540 if (*string2 == '\0') 5541 { 5542 if (is_name_suffix (string1)) 5543 return 0; 5544 else 5545 return 1; 5546 } 5547 /* FALLTHROUGH */ 5548 default: 5549 if (*string2 == '(') 5550 return strcmp_iw_ordered (string1, string2); 5551 else 5552 { 5553 if (casing == case_sensitive_off) 5554 return tolower (*string1) - tolower (*string2); 5555 else 5556 return *string1 - *string2; 5557 } 5558 } 5559} 5560 5561/* Compare STRING1 to STRING2, with results as for strcmp. 5562 Compatible with strcmp_iw_ordered in that... 5563 5564 strcmp_iw_ordered (STRING1, STRING2) <= 0 5565 5566 ... implies... 5567 5568 compare_names (STRING1, STRING2) <= 0 5569 5570 (they may differ as to what symbols compare equal). */ 5571 5572static int 5573compare_names (const char *string1, const char *string2) 5574{ 5575 int result; 5576 5577 /* Similar to what strcmp_iw_ordered does, we need to perform 5578 a case-insensitive comparison first, and only resort to 5579 a second, case-sensitive, comparison if the first one was 5580 not sufficient to differentiate the two strings. */ 5581 5582 result = compare_names_with_case (string1, string2, case_sensitive_off); 5583 if (result == 0) 5584 result = compare_names_with_case (string1, string2, case_sensitive_on); 5585 5586 return result; 5587} 5588 5589/* Convenience function to get at the Ada encoded lookup name for 5590 LOOKUP_NAME, as a C string. */ 5591 5592static const char * 5593ada_lookup_name (const lookup_name_info &lookup_name) 5594{ 5595 return lookup_name.ada ().lookup_name ().c_str (); 5596} 5597 5598/* Add to OBSTACKP all non-local symbols whose name and domain match 5599 LOOKUP_NAME and DOMAIN respectively. The search is performed on 5600 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK 5601 symbols otherwise. */ 5602 5603static void 5604add_nonlocal_symbols (struct obstack *obstackp, 5605 const lookup_name_info &lookup_name, 5606 domain_enum domain, int global) 5607{ 5608 struct match_data data; 5609 5610 memset (&data, 0, sizeof data); 5611 data.obstackp = obstackp; 5612 5613 bool is_wild_match = lookup_name.ada ().wild_match_p (); 5614 5615 for (objfile *objfile : current_program_space->objfiles ()) 5616 { 5617 data.objfile = objfile; 5618 5619 if (is_wild_match) 5620 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (), 5621 domain, global, 5622 aux_add_nonlocal_symbols, &data, 5623 symbol_name_match_type::WILD, 5624 NULL); 5625 else 5626 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (), 5627 domain, global, 5628 aux_add_nonlocal_symbols, &data, 5629 symbol_name_match_type::FULL, 5630 compare_names); 5631 5632 for (compunit_symtab *cu : objfile->compunits ()) 5633 { 5634 const struct block *global_block 5635 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK); 5636 5637 if (ada_add_block_renamings (obstackp, global_block, lookup_name, 5638 domain)) 5639 data.found_sym = 1; 5640 } 5641 } 5642 5643 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match) 5644 { 5645 const char *name = ada_lookup_name (lookup_name); 5646 std::string name1 = std::string ("<_ada_") + name + '>'; 5647 5648 for (objfile *objfile : current_program_space->objfiles ()) 5649 { 5650 data.objfile = objfile; 5651 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (), 5652 domain, global, 5653 aux_add_nonlocal_symbols, 5654 &data, 5655 symbol_name_match_type::FULL, 5656 compare_names); 5657 } 5658 } 5659} 5660 5661/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if 5662 FULL_SEARCH is non-zero, enclosing scope and in global scopes, 5663 returning the number of matches. Add these to OBSTACKP. 5664 5665 When FULL_SEARCH is non-zero, any non-function/non-enumeral 5666 symbol match within the nest of blocks whose innermost member is BLOCK, 5667 is the one match returned (no other matches in that or 5668 enclosing blocks is returned). If there are any matches in or 5669 surrounding BLOCK, then these alone are returned. 5670 5671 Names prefixed with "standard__" are handled specially: 5672 "standard__" is first stripped off (by the lookup_name 5673 constructor), and only static and global symbols are searched. 5674 5675 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had 5676 to lookup global symbols. */ 5677 5678static void 5679ada_add_all_symbols (struct obstack *obstackp, 5680 const struct block *block, 5681 const lookup_name_info &lookup_name, 5682 domain_enum domain, 5683 int full_search, 5684 int *made_global_lookup_p) 5685{ 5686 struct symbol *sym; 5687 5688 if (made_global_lookup_p) 5689 *made_global_lookup_p = 0; 5690 5691 /* Special case: If the user specifies a symbol name inside package 5692 Standard, do a non-wild matching of the symbol name without 5693 the "standard__" prefix. This was primarily introduced in order 5694 to allow the user to specifically access the standard exceptions 5695 using, for instance, Standard.Constraint_Error when Constraint_Error 5696 is ambiguous (due to the user defining its own Constraint_Error 5697 entity inside its program). */ 5698 if (lookup_name.ada ().standard_p ()) 5699 block = NULL; 5700 5701 /* Check the non-global symbols. If we have ANY match, then we're done. */ 5702 5703 if (block != NULL) 5704 { 5705 if (full_search) 5706 ada_add_local_symbols (obstackp, lookup_name, block, domain); 5707 else 5708 { 5709 /* In the !full_search case we're are being called by 5710 ada_iterate_over_symbols, and we don't want to search 5711 superblocks. */ 5712 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL); 5713 } 5714 if (num_defns_collected (obstackp) > 0 || !full_search) 5715 return; 5716 } 5717 5718 /* No non-global symbols found. Check our cache to see if we have 5719 already performed this search before. If we have, then return 5720 the same result. */ 5721 5722 if (lookup_cached_symbol (ada_lookup_name (lookup_name), 5723 domain, &sym, &block)) 5724 { 5725 if (sym != NULL) 5726 add_defn_to_vec (obstackp, sym, block); 5727 return; 5728 } 5729 5730 if (made_global_lookup_p) 5731 *made_global_lookup_p = 1; 5732 5733 /* Search symbols from all global blocks. */ 5734 5735 add_nonlocal_symbols (obstackp, lookup_name, domain, 1); 5736 5737 /* Now add symbols from all per-file blocks if we've gotten no hits 5738 (not strictly correct, but perhaps better than an error). */ 5739 5740 if (num_defns_collected (obstackp) == 0) 5741 add_nonlocal_symbols (obstackp, lookup_name, domain, 0); 5742} 5743 5744/* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH 5745 is non-zero, enclosing scope and in global scopes, returning the number of 5746 matches. 5747 Fills *RESULTS with (SYM,BLOCK) tuples, indicating the symbols 5748 found and the blocks and symbol tables (if any) in which they were 5749 found. 5750 5751 When full_search is non-zero, any non-function/non-enumeral 5752 symbol match within the nest of blocks whose innermost member is BLOCK, 5753 is the one match returned (no other matches in that or 5754 enclosing blocks is returned). If there are any matches in or 5755 surrounding BLOCK, then these alone are returned. 5756 5757 Names prefixed with "standard__" are handled specially: "standard__" 5758 is first stripped off, and only static and global symbols are searched. */ 5759 5760static int 5761ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name, 5762 const struct block *block, 5763 domain_enum domain, 5764 std::vector<struct block_symbol> *results, 5765 int full_search) 5766{ 5767 int syms_from_global_search; 5768 int ndefns; 5769 auto_obstack obstack; 5770 5771 ada_add_all_symbols (&obstack, block, lookup_name, 5772 domain, full_search, &syms_from_global_search); 5773 5774 ndefns = num_defns_collected (&obstack); 5775 5776 struct block_symbol *base = defns_collected (&obstack, 1); 5777 for (int i = 0; i < ndefns; ++i) 5778 results->push_back (base[i]); 5779 5780 ndefns = remove_extra_symbols (results); 5781 5782 if (ndefns == 0 && full_search && syms_from_global_search) 5783 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL); 5784 5785 if (ndefns == 1 && full_search && syms_from_global_search) 5786 cache_symbol (ada_lookup_name (lookup_name), domain, 5787 (*results)[0].symbol, (*results)[0].block); 5788 5789 ndefns = remove_irrelevant_renamings (results, block); 5790 5791 return ndefns; 5792} 5793 5794/* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and 5795 in global scopes, returning the number of matches, and filling *RESULTS 5796 with (SYM,BLOCK) tuples. 5797 5798 See ada_lookup_symbol_list_worker for further details. */ 5799 5800int 5801ada_lookup_symbol_list (const char *name, const struct block *block, 5802 domain_enum domain, 5803 std::vector<struct block_symbol> *results) 5804{ 5805 symbol_name_match_type name_match_type = name_match_type_from_name (name); 5806 lookup_name_info lookup_name (name, name_match_type); 5807 5808 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1); 5809} 5810 5811/* Implementation of the la_iterate_over_symbols method. */ 5812 5813static void 5814ada_iterate_over_symbols 5815 (const struct block *block, const lookup_name_info &name, 5816 domain_enum domain, 5817 gdb::function_view<symbol_found_callback_ftype> callback) 5818{ 5819 int ndefs, i; 5820 std::vector<struct block_symbol> results; 5821 5822 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0); 5823 5824 for (i = 0; i < ndefs; ++i) 5825 { 5826 if (!callback (&results[i])) 5827 break; 5828 } 5829} 5830 5831/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set 5832 to 1, but choosing the first symbol found if there are multiple 5833 choices. 5834 5835 The result is stored in *INFO, which must be non-NULL. 5836 If no match is found, INFO->SYM is set to NULL. */ 5837 5838void 5839ada_lookup_encoded_symbol (const char *name, const struct block *block, 5840 domain_enum domain, 5841 struct block_symbol *info) 5842{ 5843 /* Since we already have an encoded name, wrap it in '<>' to force a 5844 verbatim match. Otherwise, if the name happens to not look like 5845 an encoded name (because it doesn't include a "__"), 5846 ada_lookup_name_info would re-encode/fold it again, and that 5847 would e.g., incorrectly lowercase object renaming names like 5848 "R28b" -> "r28b". */ 5849 std::string verbatim = std::string ("<") + name + '>'; 5850 5851 gdb_assert (info != NULL); 5852 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL); 5853} 5854 5855/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing 5856 scope and in global scopes, or NULL if none. NAME is folded and 5857 encoded first. Otherwise, the result is as for ada_lookup_symbol_list, 5858 choosing the first symbol if there are multiple choices. 5859 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */ 5860 5861struct block_symbol 5862ada_lookup_symbol (const char *name, const struct block *block0, 5863 domain_enum domain, int *is_a_field_of_this) 5864{ 5865 if (is_a_field_of_this != NULL) 5866 *is_a_field_of_this = 0; 5867 5868 std::vector<struct block_symbol> candidates; 5869 int n_candidates; 5870 5871 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates); 5872 5873 if (n_candidates == 0) 5874 return {}; 5875 5876 block_symbol info = candidates[0]; 5877 info.symbol = fixup_symbol_section (info.symbol, NULL); 5878 return info; 5879} 5880 5881static struct block_symbol 5882ada_lookup_symbol_nonlocal (const struct language_defn *langdef, 5883 const char *name, 5884 const struct block *block, 5885 const domain_enum domain) 5886{ 5887 struct block_symbol sym; 5888 5889 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL); 5890 if (sym.symbol != NULL) 5891 return sym; 5892 5893 /* If we haven't found a match at this point, try the primitive 5894 types. In other languages, this search is performed before 5895 searching for global symbols in order to short-circuit that 5896 global-symbol search if it happens that the name corresponds 5897 to a primitive type. But we cannot do the same in Ada, because 5898 it is perfectly legitimate for a program to declare a type which 5899 has the same name as a standard type. If looking up a type in 5900 that situation, we have traditionally ignored the primitive type 5901 in favor of user-defined types. This is why, unlike most other 5902 languages, we search the primitive types this late and only after 5903 having searched the global symbols without success. */ 5904 5905 if (domain == VAR_DOMAIN) 5906 { 5907 struct gdbarch *gdbarch; 5908 5909 if (block == NULL) 5910 gdbarch = target_gdbarch (); 5911 else 5912 gdbarch = block_gdbarch (block); 5913 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name); 5914 if (sym.symbol != NULL) 5915 return sym; 5916 } 5917 5918 return (struct block_symbol) {NULL, NULL}; 5919} 5920 5921 5922/* True iff STR is a possible encoded suffix of a normal Ada name 5923 that is to be ignored for matching purposes. Suffixes of parallel 5924 names (e.g., XVE) are not included here. Currently, the possible suffixes 5925 are given by any of the regular expressions: 5926 5927 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux] 5928 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX] 5929 TKB [subprogram suffix for task bodies] 5930 _E[0-9]+[bs]$ [protected object entry suffixes] 5931 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$ 5932 5933 Also, any leading "__[0-9]+" sequence is skipped before the suffix 5934 match is performed. This sequence is used to differentiate homonyms, 5935 is an optional part of a valid name suffix. */ 5936 5937static int 5938is_name_suffix (const char *str) 5939{ 5940 int k; 5941 const char *matching; 5942 const int len = strlen (str); 5943 5944 /* Skip optional leading __[0-9]+. */ 5945 5946 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2])) 5947 { 5948 str += 3; 5949 while (isdigit (str[0])) 5950 str += 1; 5951 } 5952 5953 /* [.$][0-9]+ */ 5954 5955 if (str[0] == '.' || str[0] == '$') 5956 { 5957 matching = str + 1; 5958 while (isdigit (matching[0])) 5959 matching += 1; 5960 if (matching[0] == '\0') 5961 return 1; 5962 } 5963 5964 /* ___[0-9]+ */ 5965 5966 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_') 5967 { 5968 matching = str + 3; 5969 while (isdigit (matching[0])) 5970 matching += 1; 5971 if (matching[0] == '\0') 5972 return 1; 5973 } 5974 5975 /* "TKB" suffixes are used for subprograms implementing task bodies. */ 5976 5977 if (strcmp (str, "TKB") == 0) 5978 return 1; 5979 5980#if 0 5981 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end 5982 with a N at the end. Unfortunately, the compiler uses the same 5983 convention for other internal types it creates. So treating 5984 all entity names that end with an "N" as a name suffix causes 5985 some regressions. For instance, consider the case of an enumerated 5986 type. To support the 'Image attribute, it creates an array whose 5987 name ends with N. 5988 Having a single character like this as a suffix carrying some 5989 information is a bit risky. Perhaps we should change the encoding 5990 to be something like "_N" instead. In the meantime, do not do 5991 the following check. */ 5992 /* Protected Object Subprograms */ 5993 if (len == 1 && str [0] == 'N') 5994 return 1; 5995#endif 5996 5997 /* _E[0-9]+[bs]$ */ 5998 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2])) 5999 { 6000 matching = str + 3; 6001 while (isdigit (matching[0])) 6002 matching += 1; 6003 if ((matching[0] == 'b' || matching[0] == 's') 6004 && matching [1] == '\0') 6005 return 1; 6006 } 6007 6008 /* ??? We should not modify STR directly, as we are doing below. This 6009 is fine in this case, but may become problematic later if we find 6010 that this alternative did not work, and want to try matching 6011 another one from the begining of STR. Since we modified it, we 6012 won't be able to find the begining of the string anymore! */ 6013 if (str[0] == 'X') 6014 { 6015 str += 1; 6016 while (str[0] != '_' && str[0] != '\0') 6017 { 6018 if (str[0] != 'n' && str[0] != 'b') 6019 return 0; 6020 str += 1; 6021 } 6022 } 6023 6024 if (str[0] == '\000') 6025 return 1; 6026 6027 if (str[0] == '_') 6028 { 6029 if (str[1] != '_' || str[2] == '\000') 6030 return 0; 6031 if (str[2] == '_') 6032 { 6033 if (strcmp (str + 3, "JM") == 0) 6034 return 1; 6035 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using 6036 the LJM suffix in favor of the JM one. But we will 6037 still accept LJM as a valid suffix for a reasonable 6038 amount of time, just to allow ourselves to debug programs 6039 compiled using an older version of GNAT. */ 6040 if (strcmp (str + 3, "LJM") == 0) 6041 return 1; 6042 if (str[3] != 'X') 6043 return 0; 6044 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B' 6045 || str[4] == 'U' || str[4] == 'P') 6046 return 1; 6047 if (str[4] == 'R' && str[5] != 'T') 6048 return 1; 6049 return 0; 6050 } 6051 if (!isdigit (str[2])) 6052 return 0; 6053 for (k = 3; str[k] != '\0'; k += 1) 6054 if (!isdigit (str[k]) && str[k] != '_') 6055 return 0; 6056 return 1; 6057 } 6058 if (str[0] == '$' && isdigit (str[1])) 6059 { 6060 for (k = 2; str[k] != '\0'; k += 1) 6061 if (!isdigit (str[k]) && str[k] != '_') 6062 return 0; 6063 return 1; 6064 } 6065 return 0; 6066} 6067 6068/* Return non-zero if the string starting at NAME and ending before 6069 NAME_END contains no capital letters. */ 6070 6071static int 6072is_valid_name_for_wild_match (const char *name0) 6073{ 6074 const char *decoded_name = ada_decode (name0); 6075 int i; 6076 6077 /* If the decoded name starts with an angle bracket, it means that 6078 NAME0 does not follow the GNAT encoding format. It should then 6079 not be allowed as a possible wild match. */ 6080 if (decoded_name[0] == '<') 6081 return 0; 6082 6083 for (i=0; decoded_name[i] != '\0'; i++) 6084 if (isalpha (decoded_name[i]) && !islower (decoded_name[i])) 6085 return 0; 6086 6087 return 1; 6088} 6089 6090/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0 6091 that could start a simple name. Assumes that *NAMEP points into 6092 the string beginning at NAME0. */ 6093 6094static int 6095advance_wild_match (const char **namep, const char *name0, int target0) 6096{ 6097 const char *name = *namep; 6098 6099 while (1) 6100 { 6101 int t0, t1; 6102 6103 t0 = *name; 6104 if (t0 == '_') 6105 { 6106 t1 = name[1]; 6107 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9')) 6108 { 6109 name += 1; 6110 if (name == name0 + 5 && startswith (name0, "_ada")) 6111 break; 6112 else 6113 name += 1; 6114 } 6115 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z') 6116 || name[2] == target0)) 6117 { 6118 name += 2; 6119 break; 6120 } 6121 else 6122 return 0; 6123 } 6124 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9')) 6125 name += 1; 6126 else 6127 return 0; 6128 } 6129 6130 *namep = name; 6131 return 1; 6132} 6133 6134/* Return true iff NAME encodes a name of the form prefix.PATN. 6135 Ignores any informational suffixes of NAME (i.e., for which 6136 is_name_suffix is true). Assumes that PATN is a lower-cased Ada 6137 simple name. */ 6138 6139static bool 6140wild_match (const char *name, const char *patn) 6141{ 6142 const char *p; 6143 const char *name0 = name; 6144 6145 while (1) 6146 { 6147 const char *match = name; 6148 6149 if (*name == *patn) 6150 { 6151 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1) 6152 if (*p != *name) 6153 break; 6154 if (*p == '\0' && is_name_suffix (name)) 6155 return match == name0 || is_valid_name_for_wild_match (name0); 6156 6157 if (name[-1] == '_') 6158 name -= 1; 6159 } 6160 if (!advance_wild_match (&name, name0, *patn)) 6161 return false; 6162 } 6163} 6164 6165/* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring 6166 any trailing suffixes that encode debugging information or leading 6167 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging 6168 information that is ignored). */ 6169 6170static bool 6171full_match (const char *sym_name, const char *search_name) 6172{ 6173 size_t search_name_len = strlen (search_name); 6174 6175 if (strncmp (sym_name, search_name, search_name_len) == 0 6176 && is_name_suffix (sym_name + search_name_len)) 6177 return true; 6178 6179 if (startswith (sym_name, "_ada_") 6180 && strncmp (sym_name + 5, search_name, search_name_len) == 0 6181 && is_name_suffix (sym_name + search_name_len + 5)) 6182 return true; 6183 6184 return false; 6185} 6186 6187/* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector 6188 *defn_symbols, updating the list of symbols in OBSTACKP (if 6189 necessary). OBJFILE is the section containing BLOCK. */ 6190 6191static void 6192ada_add_block_symbols (struct obstack *obstackp, 6193 const struct block *block, 6194 const lookup_name_info &lookup_name, 6195 domain_enum domain, struct objfile *objfile) 6196{ 6197 struct block_iterator iter; 6198 /* A matching argument symbol, if any. */ 6199 struct symbol *arg_sym; 6200 /* Set true when we find a matching non-argument symbol. */ 6201 int found_sym; 6202 struct symbol *sym; 6203 6204 arg_sym = NULL; 6205 found_sym = 0; 6206 for (sym = block_iter_match_first (block, lookup_name, &iter); 6207 sym != NULL; 6208 sym = block_iter_match_next (lookup_name, &iter)) 6209 { 6210 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym), 6211 SYMBOL_DOMAIN (sym), domain)) 6212 { 6213 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED) 6214 { 6215 if (SYMBOL_IS_ARGUMENT (sym)) 6216 arg_sym = sym; 6217 else 6218 { 6219 found_sym = 1; 6220 add_defn_to_vec (obstackp, 6221 fixup_symbol_section (sym, objfile), 6222 block); 6223 } 6224 } 6225 } 6226 } 6227 6228 /* Handle renamings. */ 6229 6230 if (ada_add_block_renamings (obstackp, block, lookup_name, domain)) 6231 found_sym = 1; 6232 6233 if (!found_sym && arg_sym != NULL) 6234 { 6235 add_defn_to_vec (obstackp, 6236 fixup_symbol_section (arg_sym, objfile), 6237 block); 6238 } 6239 6240 if (!lookup_name.ada ().wild_match_p ()) 6241 { 6242 arg_sym = NULL; 6243 found_sym = 0; 6244 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name (); 6245 const char *name = ada_lookup_name.c_str (); 6246 size_t name_len = ada_lookup_name.size (); 6247 6248 ALL_BLOCK_SYMBOLS (block, iter, sym) 6249 { 6250 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym), 6251 SYMBOL_DOMAIN (sym), domain)) 6252 { 6253 int cmp; 6254 6255 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0]; 6256 if (cmp == 0) 6257 { 6258 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_"); 6259 if (cmp == 0) 6260 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5, 6261 name_len); 6262 } 6263 6264 if (cmp == 0 6265 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5)) 6266 { 6267 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED) 6268 { 6269 if (SYMBOL_IS_ARGUMENT (sym)) 6270 arg_sym = sym; 6271 else 6272 { 6273 found_sym = 1; 6274 add_defn_to_vec (obstackp, 6275 fixup_symbol_section (sym, objfile), 6276 block); 6277 } 6278 } 6279 } 6280 } 6281 } 6282 6283 /* NOTE: This really shouldn't be needed for _ada_ symbols. 6284 They aren't parameters, right? */ 6285 if (!found_sym && arg_sym != NULL) 6286 { 6287 add_defn_to_vec (obstackp, 6288 fixup_symbol_section (arg_sym, objfile), 6289 block); 6290 } 6291 } 6292} 6293 6294 6295 /* Symbol Completion */ 6296 6297/* See symtab.h. */ 6298 6299bool 6300ada_lookup_name_info::matches 6301 (const char *sym_name, 6302 symbol_name_match_type match_type, 6303 completion_match_result *comp_match_res) const 6304{ 6305 bool match = false; 6306 const char *text = m_encoded_name.c_str (); 6307 size_t text_len = m_encoded_name.size (); 6308 6309 /* First, test against the fully qualified name of the symbol. */ 6310 6311 if (strncmp (sym_name, text, text_len) == 0) 6312 match = true; 6313 6314 if (match && !m_encoded_p) 6315 { 6316 /* One needed check before declaring a positive match is to verify 6317 that iff we are doing a verbatim match, the decoded version 6318 of the symbol name starts with '<'. Otherwise, this symbol name 6319 is not a suitable completion. */ 6320 const char *sym_name_copy = sym_name; 6321 bool has_angle_bracket; 6322 6323 sym_name = ada_decode (sym_name); 6324 has_angle_bracket = (sym_name[0] == '<'); 6325 match = (has_angle_bracket == m_verbatim_p); 6326 sym_name = sym_name_copy; 6327 } 6328 6329 if (match && !m_verbatim_p) 6330 { 6331 /* When doing non-verbatim match, another check that needs to 6332 be done is to verify that the potentially matching symbol name 6333 does not include capital letters, because the ada-mode would 6334 not be able to understand these symbol names without the 6335 angle bracket notation. */ 6336 const char *tmp; 6337 6338 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++); 6339 if (*tmp != '\0') 6340 match = false; 6341 } 6342 6343 /* Second: Try wild matching... */ 6344 6345 if (!match && m_wild_match_p) 6346 { 6347 /* Since we are doing wild matching, this means that TEXT 6348 may represent an unqualified symbol name. We therefore must 6349 also compare TEXT against the unqualified name of the symbol. */ 6350 sym_name = ada_unqualified_name (ada_decode (sym_name)); 6351 6352 if (strncmp (sym_name, text, text_len) == 0) 6353 match = true; 6354 } 6355 6356 /* Finally: If we found a match, prepare the result to return. */ 6357 6358 if (!match) 6359 return false; 6360 6361 if (comp_match_res != NULL) 6362 { 6363 std::string &match_str = comp_match_res->match.storage (); 6364 6365 if (!m_encoded_p) 6366 match_str = ada_decode (sym_name); 6367 else 6368 { 6369 if (m_verbatim_p) 6370 match_str = add_angle_brackets (sym_name); 6371 else 6372 match_str = sym_name; 6373 6374 } 6375 6376 comp_match_res->set_match (match_str.c_str ()); 6377 } 6378 6379 return true; 6380} 6381 6382/* Add the list of possible symbol names completing TEXT to TRACKER. 6383 WORD is the entire command on which completion is made. */ 6384 6385static void 6386ada_collect_symbol_completion_matches (completion_tracker &tracker, 6387 complete_symbol_mode mode, 6388 symbol_name_match_type name_match_type, 6389 const char *text, const char *word, 6390 enum type_code code) 6391{ 6392 struct symbol *sym; 6393 const struct block *b, *surrounding_static_block = 0; 6394 struct block_iterator iter; 6395 6396 gdb_assert (code == TYPE_CODE_UNDEF); 6397 6398 lookup_name_info lookup_name (text, name_match_type, true); 6399 6400 /* First, look at the partial symtab symbols. */ 6401 expand_symtabs_matching (NULL, 6402 lookup_name, 6403 NULL, 6404 NULL, 6405 ALL_DOMAIN); 6406 6407 /* At this point scan through the misc symbol vectors and add each 6408 symbol you find to the list. Eventually we want to ignore 6409 anything that isn't a text symbol (everything else will be 6410 handled by the psymtab code above). */ 6411 6412 for (objfile *objfile : current_program_space->objfiles ()) 6413 { 6414 for (minimal_symbol *msymbol : objfile->msymbols ()) 6415 { 6416 QUIT; 6417 6418 if (completion_skip_symbol (mode, msymbol)) 6419 continue; 6420 6421 language symbol_language = MSYMBOL_LANGUAGE (msymbol); 6422 6423 /* Ada minimal symbols won't have their language set to Ada. If 6424 we let completion_list_add_name compare using the 6425 default/C-like matcher, then when completing e.g., symbols in a 6426 package named "pck", we'd match internal Ada symbols like 6427 "pckS", which are invalid in an Ada expression, unless you wrap 6428 them in '<' '>' to request a verbatim match. 6429 6430 Unfortunately, some Ada encoded names successfully demangle as 6431 C++ symbols (using an old mangling scheme), such as "name__2Xn" 6432 -> "Xn::name(void)" and thus some Ada minimal symbols end up 6433 with the wrong language set. Paper over that issue here. */ 6434 if (symbol_language == language_auto 6435 || symbol_language == language_cplus) 6436 symbol_language = language_ada; 6437 6438 completion_list_add_name (tracker, 6439 symbol_language, 6440 MSYMBOL_LINKAGE_NAME (msymbol), 6441 lookup_name, text, word); 6442 } 6443 } 6444 6445 /* Search upwards from currently selected frame (so that we can 6446 complete on local vars. */ 6447 6448 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b)) 6449 { 6450 if (!BLOCK_SUPERBLOCK (b)) 6451 surrounding_static_block = b; /* For elmin of dups */ 6452 6453 ALL_BLOCK_SYMBOLS (b, iter, sym) 6454 { 6455 if (completion_skip_symbol (mode, sym)) 6456 continue; 6457 6458 completion_list_add_name (tracker, 6459 SYMBOL_LANGUAGE (sym), 6460 SYMBOL_LINKAGE_NAME (sym), 6461 lookup_name, text, word); 6462 } 6463 } 6464 6465 /* Go through the symtabs and check the externs and statics for 6466 symbols which match. */ 6467 6468 for (objfile *objfile : current_program_space->objfiles ()) 6469 { 6470 for (compunit_symtab *s : objfile->compunits ()) 6471 { 6472 QUIT; 6473 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK); 6474 ALL_BLOCK_SYMBOLS (b, iter, sym) 6475 { 6476 if (completion_skip_symbol (mode, sym)) 6477 continue; 6478 6479 completion_list_add_name (tracker, 6480 SYMBOL_LANGUAGE (sym), 6481 SYMBOL_LINKAGE_NAME (sym), 6482 lookup_name, text, word); 6483 } 6484 } 6485 } 6486 6487 for (objfile *objfile : current_program_space->objfiles ()) 6488 { 6489 for (compunit_symtab *s : objfile->compunits ()) 6490 { 6491 QUIT; 6492 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK); 6493 /* Don't do this block twice. */ 6494 if (b == surrounding_static_block) 6495 continue; 6496 ALL_BLOCK_SYMBOLS (b, iter, sym) 6497 { 6498 if (completion_skip_symbol (mode, sym)) 6499 continue; 6500 6501 completion_list_add_name (tracker, 6502 SYMBOL_LANGUAGE (sym), 6503 SYMBOL_LINKAGE_NAME (sym), 6504 lookup_name, text, word); 6505 } 6506 } 6507 } 6508} 6509 6510 /* Field Access */ 6511 6512/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used 6513 for tagged types. */ 6514 6515static int 6516ada_is_dispatch_table_ptr_type (struct type *type) 6517{ 6518 const char *name; 6519 6520 if (TYPE_CODE (type) != TYPE_CODE_PTR) 6521 return 0; 6522 6523 name = TYPE_NAME (TYPE_TARGET_TYPE (type)); 6524 if (name == NULL) 6525 return 0; 6526 6527 return (strcmp (name, "ada__tags__dispatch_table") == 0); 6528} 6529 6530/* Return non-zero if TYPE is an interface tag. */ 6531 6532static int 6533ada_is_interface_tag (struct type *type) 6534{ 6535 const char *name = TYPE_NAME (type); 6536 6537 if (name == NULL) 6538 return 0; 6539 6540 return (strcmp (name, "ada__tags__interface_tag") == 0); 6541} 6542 6543/* True if field number FIELD_NUM in struct or union type TYPE is supposed 6544 to be invisible to users. */ 6545 6546int 6547ada_is_ignored_field (struct type *type, int field_num) 6548{ 6549 if (field_num < 0 || field_num > TYPE_NFIELDS (type)) 6550 return 1; 6551 6552 /* Check the name of that field. */ 6553 { 6554 const char *name = TYPE_FIELD_NAME (type, field_num); 6555 6556 /* Anonymous field names should not be printed. 6557 brobecker/2007-02-20: I don't think this can actually happen 6558 but we don't want to print the value of annonymous fields anyway. */ 6559 if (name == NULL) 6560 return 1; 6561 6562 /* Normally, fields whose name start with an underscore ("_") 6563 are fields that have been internally generated by the compiler, 6564 and thus should not be printed. The "_parent" field is special, 6565 however: This is a field internally generated by the compiler 6566 for tagged types, and it contains the components inherited from 6567 the parent type. This field should not be printed as is, but 6568 should not be ignored either. */ 6569 if (name[0] == '_' && !startswith (name, "_parent")) 6570 return 1; 6571 } 6572 6573 /* If this is the dispatch table of a tagged type or an interface tag, 6574 then ignore. */ 6575 if (ada_is_tagged_type (type, 1) 6576 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)) 6577 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num)))) 6578 return 1; 6579 6580 /* Not a special field, so it should not be ignored. */ 6581 return 0; 6582} 6583 6584/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a 6585 pointer or reference type whose ultimate target has a tag field. */ 6586 6587int 6588ada_is_tagged_type (struct type *type, int refok) 6589{ 6590 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL); 6591} 6592 6593/* True iff TYPE represents the type of X'Tag */ 6594 6595int 6596ada_is_tag_type (struct type *type) 6597{ 6598 type = ada_check_typedef (type); 6599 6600 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR) 6601 return 0; 6602 else 6603 { 6604 const char *name = ada_type_name (TYPE_TARGET_TYPE (type)); 6605 6606 return (name != NULL 6607 && strcmp (name, "ada__tags__dispatch_table") == 0); 6608 } 6609} 6610 6611/* The type of the tag on VAL. */ 6612 6613struct type * 6614ada_tag_type (struct value *val) 6615{ 6616 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0); 6617} 6618 6619/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95, 6620 retired at Ada 05). */ 6621 6622static int 6623is_ada95_tag (struct value *tag) 6624{ 6625 return ada_value_struct_elt (tag, "tsd", 1) != NULL; 6626} 6627 6628/* The value of the tag on VAL. */ 6629 6630struct value * 6631ada_value_tag (struct value *val) 6632{ 6633 return ada_value_struct_elt (val, "_tag", 0); 6634} 6635 6636/* The value of the tag on the object of type TYPE whose contents are 6637 saved at VALADDR, if it is non-null, or is at memory address 6638 ADDRESS. */ 6639 6640static struct value * 6641value_tag_from_contents_and_address (struct type *type, 6642 const gdb_byte *valaddr, 6643 CORE_ADDR address) 6644{ 6645 int tag_byte_offset; 6646 struct type *tag_type; 6647 6648 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset, 6649 NULL, NULL, NULL)) 6650 { 6651 const gdb_byte *valaddr1 = ((valaddr == NULL) 6652 ? NULL 6653 : valaddr + tag_byte_offset); 6654 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset; 6655 6656 return value_from_contents_and_address (tag_type, valaddr1, address1); 6657 } 6658 return NULL; 6659} 6660 6661static struct type * 6662type_from_tag (struct value *tag) 6663{ 6664 const char *type_name = ada_tag_name (tag); 6665 6666 if (type_name != NULL) 6667 return ada_find_any_type (ada_encode (type_name)); 6668 return NULL; 6669} 6670 6671/* Given a value OBJ of a tagged type, return a value of this 6672 type at the base address of the object. The base address, as 6673 defined in Ada.Tags, it is the address of the primary tag of 6674 the object, and therefore where the field values of its full 6675 view can be fetched. */ 6676 6677struct value * 6678ada_tag_value_at_base_address (struct value *obj) 6679{ 6680 struct value *val; 6681 LONGEST offset_to_top = 0; 6682 struct type *ptr_type, *obj_type; 6683 struct value *tag; 6684 CORE_ADDR base_address; 6685 6686 obj_type = value_type (obj); 6687 6688 /* It is the responsability of the caller to deref pointers. */ 6689 6690 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR 6691 || TYPE_CODE (obj_type) == TYPE_CODE_REF) 6692 return obj; 6693 6694 tag = ada_value_tag (obj); 6695 if (!tag) 6696 return obj; 6697 6698 /* Base addresses only appeared with Ada 05 and multiple inheritance. */ 6699 6700 if (is_ada95_tag (tag)) 6701 return obj; 6702 6703 ptr_type = language_lookup_primitive_type 6704 (language_def (language_ada), target_gdbarch(), "storage_offset"); 6705 ptr_type = lookup_pointer_type (ptr_type); 6706 val = value_cast (ptr_type, tag); 6707 if (!val) 6708 return obj; 6709 6710 /* It is perfectly possible that an exception be raised while 6711 trying to determine the base address, just like for the tag; 6712 see ada_tag_name for more details. We do not print the error 6713 message for the same reason. */ 6714 6715 TRY 6716 { 6717 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2))); 6718 } 6719 6720 CATCH (e, RETURN_MASK_ERROR) 6721 { 6722 return obj; 6723 } 6724 END_CATCH 6725 6726 /* If offset is null, nothing to do. */ 6727 6728 if (offset_to_top == 0) 6729 return obj; 6730 6731 /* -1 is a special case in Ada.Tags; however, what should be done 6732 is not quite clear from the documentation. So do nothing for 6733 now. */ 6734 6735 if (offset_to_top == -1) 6736 return obj; 6737 6738 /* OFFSET_TO_TOP used to be a positive value to be subtracted 6739 from the base address. This was however incompatible with 6740 C++ dispatch table: C++ uses a *negative* value to *add* 6741 to the base address. Ada's convention has therefore been 6742 changed in GNAT 19.0w 20171023: since then, C++ and Ada 6743 use the same convention. Here, we support both cases by 6744 checking the sign of OFFSET_TO_TOP. */ 6745 6746 if (offset_to_top > 0) 6747 offset_to_top = -offset_to_top; 6748 6749 base_address = value_address (obj) + offset_to_top; 6750 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address); 6751 6752 /* Make sure that we have a proper tag at the new address. 6753 Otherwise, offset_to_top is bogus (which can happen when 6754 the object is not initialized yet). */ 6755 6756 if (!tag) 6757 return obj; 6758 6759 obj_type = type_from_tag (tag); 6760 6761 if (!obj_type) 6762 return obj; 6763 6764 return value_from_contents_and_address (obj_type, NULL, base_address); 6765} 6766 6767/* Return the "ada__tags__type_specific_data" type. */ 6768 6769static struct type * 6770ada_get_tsd_type (struct inferior *inf) 6771{ 6772 struct ada_inferior_data *data = get_ada_inferior_data (inf); 6773 6774 if (data->tsd_type == 0) 6775 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data"); 6776 return data->tsd_type; 6777} 6778 6779/* Return the TSD (type-specific data) associated to the given TAG. 6780 TAG is assumed to be the tag of a tagged-type entity. 6781 6782 May return NULL if we are unable to get the TSD. */ 6783 6784static struct value * 6785ada_get_tsd_from_tag (struct value *tag) 6786{ 6787 struct value *val; 6788 struct type *type; 6789 6790 /* First option: The TSD is simply stored as a field of our TAG. 6791 Only older versions of GNAT would use this format, but we have 6792 to test it first, because there are no visible markers for 6793 the current approach except the absence of that field. */ 6794 6795 val = ada_value_struct_elt (tag, "tsd", 1); 6796 if (val) 6797 return val; 6798 6799 /* Try the second representation for the dispatch table (in which 6800 there is no explicit 'tsd' field in the referent of the tag pointer, 6801 and instead the tsd pointer is stored just before the dispatch 6802 table. */ 6803 6804 type = ada_get_tsd_type (current_inferior()); 6805 if (type == NULL) 6806 return NULL; 6807 type = lookup_pointer_type (lookup_pointer_type (type)); 6808 val = value_cast (type, tag); 6809 if (val == NULL) 6810 return NULL; 6811 return value_ind (value_ptradd (val, -1)); 6812} 6813 6814/* Given the TSD of a tag (type-specific data), return a string 6815 containing the name of the associated type. 6816 6817 The returned value is good until the next call. May return NULL 6818 if we are unable to determine the tag name. */ 6819 6820static char * 6821ada_tag_name_from_tsd (struct value *tsd) 6822{ 6823 static char name[1024]; 6824 char *p; 6825 struct value *val; 6826 6827 val = ada_value_struct_elt (tsd, "expanded_name", 1); 6828 if (val == NULL) 6829 return NULL; 6830 read_memory_string (value_as_address (val), name, sizeof (name) - 1); 6831 for (p = name; *p != '\0'; p += 1) 6832 if (isalpha (*p)) 6833 *p = tolower (*p); 6834 return name; 6835} 6836 6837/* The type name of the dynamic type denoted by the 'tag value TAG, as 6838 a C string. 6839 6840 Return NULL if the TAG is not an Ada tag, or if we were unable to 6841 determine the name of that tag. The result is good until the next 6842 call. */ 6843 6844const char * 6845ada_tag_name (struct value *tag) 6846{ 6847 char *name = NULL; 6848 6849 if (!ada_is_tag_type (value_type (tag))) 6850 return NULL; 6851 6852 /* It is perfectly possible that an exception be raised while trying 6853 to determine the TAG's name, even under normal circumstances: 6854 The associated variable may be uninitialized or corrupted, for 6855 instance. We do not let any exception propagate past this point. 6856 instead we return NULL. 6857 6858 We also do not print the error message either (which often is very 6859 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let 6860 the caller print a more meaningful message if necessary. */ 6861 TRY 6862 { 6863 struct value *tsd = ada_get_tsd_from_tag (tag); 6864 6865 if (tsd != NULL) 6866 name = ada_tag_name_from_tsd (tsd); 6867 } 6868 CATCH (e, RETURN_MASK_ERROR) 6869 { 6870 } 6871 END_CATCH 6872 6873 return name; 6874} 6875 6876/* The parent type of TYPE, or NULL if none. */ 6877 6878struct type * 6879ada_parent_type (struct type *type) 6880{ 6881 int i; 6882 6883 type = ada_check_typedef (type); 6884 6885 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT) 6886 return NULL; 6887 6888 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 6889 if (ada_is_parent_field (type, i)) 6890 { 6891 struct type *parent_type = TYPE_FIELD_TYPE (type, i); 6892 6893 /* If the _parent field is a pointer, then dereference it. */ 6894 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR) 6895 parent_type = TYPE_TARGET_TYPE (parent_type); 6896 /* If there is a parallel XVS type, get the actual base type. */ 6897 parent_type = ada_get_base_type (parent_type); 6898 6899 return ada_check_typedef (parent_type); 6900 } 6901 6902 return NULL; 6903} 6904 6905/* True iff field number FIELD_NUM of structure type TYPE contains the 6906 parent-type (inherited) fields of a derived type. Assumes TYPE is 6907 a structure type with at least FIELD_NUM+1 fields. */ 6908 6909int 6910ada_is_parent_field (struct type *type, int field_num) 6911{ 6912 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num); 6913 6914 return (name != NULL 6915 && (startswith (name, "PARENT") 6916 || startswith (name, "_parent"))); 6917} 6918 6919/* True iff field number FIELD_NUM of structure type TYPE is a 6920 transparent wrapper field (which should be silently traversed when doing 6921 field selection and flattened when printing). Assumes TYPE is a 6922 structure type with at least FIELD_NUM+1 fields. Such fields are always 6923 structures. */ 6924 6925int 6926ada_is_wrapper_field (struct type *type, int field_num) 6927{ 6928 const char *name = TYPE_FIELD_NAME (type, field_num); 6929 6930 if (name != NULL && strcmp (name, "RETVAL") == 0) 6931 { 6932 /* This happens in functions with "out" or "in out" parameters 6933 which are passed by copy. For such functions, GNAT describes 6934 the function's return type as being a struct where the return 6935 value is in a field called RETVAL, and where the other "out" 6936 or "in out" parameters are fields of that struct. This is not 6937 a wrapper. */ 6938 return 0; 6939 } 6940 6941 return (name != NULL 6942 && (startswith (name, "PARENT") 6943 || strcmp (name, "REP") == 0 6944 || startswith (name, "_parent") 6945 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O')); 6946} 6947 6948/* True iff field number FIELD_NUM of structure or union type TYPE 6949 is a variant wrapper. Assumes TYPE is a structure type with at least 6950 FIELD_NUM+1 fields. */ 6951 6952int 6953ada_is_variant_part (struct type *type, int field_num) 6954{ 6955 struct type *field_type = TYPE_FIELD_TYPE (type, field_num); 6956 6957 return (TYPE_CODE (field_type) == TYPE_CODE_UNION 6958 || (is_dynamic_field (type, field_num) 6959 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type)) 6960 == TYPE_CODE_UNION))); 6961} 6962 6963/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part) 6964 whose discriminants are contained in the record type OUTER_TYPE, 6965 returns the type of the controlling discriminant for the variant. 6966 May return NULL if the type could not be found. */ 6967 6968struct type * 6969ada_variant_discrim_type (struct type *var_type, struct type *outer_type) 6970{ 6971 const char *name = ada_variant_discrim_name (var_type); 6972 6973 return ada_lookup_struct_elt_type (outer_type, name, 1, 1); 6974} 6975 6976/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a 6977 valid field number within it, returns 1 iff field FIELD_NUM of TYPE 6978 represents a 'when others' clause; otherwise 0. */ 6979 6980int 6981ada_is_others_clause (struct type *type, int field_num) 6982{ 6983 const char *name = TYPE_FIELD_NAME (type, field_num); 6984 6985 return (name != NULL && name[0] == 'O'); 6986} 6987 6988/* Assuming that TYPE0 is the type of the variant part of a record, 6989 returns the name of the discriminant controlling the variant. 6990 The value is valid until the next call to ada_variant_discrim_name. */ 6991 6992const char * 6993ada_variant_discrim_name (struct type *type0) 6994{ 6995 static char *result = NULL; 6996 static size_t result_len = 0; 6997 struct type *type; 6998 const char *name; 6999 const char *discrim_end; 7000 const char *discrim_start; 7001 7002 if (TYPE_CODE (type0) == TYPE_CODE_PTR) 7003 type = TYPE_TARGET_TYPE (type0); 7004 else 7005 type = type0; 7006 7007 name = ada_type_name (type); 7008 7009 if (name == NULL || name[0] == '\000') 7010 return ""; 7011 7012 for (discrim_end = name + strlen (name) - 6; discrim_end != name; 7013 discrim_end -= 1) 7014 { 7015 if (startswith (discrim_end, "___XVN")) 7016 break; 7017 } 7018 if (discrim_end == name) 7019 return ""; 7020 7021 for (discrim_start = discrim_end; discrim_start != name + 3; 7022 discrim_start -= 1) 7023 { 7024 if (discrim_start == name + 1) 7025 return ""; 7026 if ((discrim_start > name + 3 7027 && startswith (discrim_start - 3, "___")) 7028 || discrim_start[-1] == '.') 7029 break; 7030 } 7031 7032 GROW_VECT (result, result_len, discrim_end - discrim_start + 1); 7033 strncpy (result, discrim_start, discrim_end - discrim_start); 7034 result[discrim_end - discrim_start] = '\0'; 7035 return result; 7036} 7037 7038/* Scan STR for a subtype-encoded number, beginning at position K. 7039 Put the position of the character just past the number scanned in 7040 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. 7041 Return 1 if there was a valid number at the given position, and 0 7042 otherwise. A "subtype-encoded" number consists of the absolute value 7043 in decimal, followed by the letter 'm' to indicate a negative number. 7044 Assumes 0m does not occur. */ 7045 7046int 7047ada_scan_number (const char str[], int k, LONGEST * R, int *new_k) 7048{ 7049 ULONGEST RU; 7050 7051 if (!isdigit (str[k])) 7052 return 0; 7053 7054 /* Do it the hard way so as not to make any assumption about 7055 the relationship of unsigned long (%lu scan format code) and 7056 LONGEST. */ 7057 RU = 0; 7058 while (isdigit (str[k])) 7059 { 7060 RU = RU * 10 + (str[k] - '0'); 7061 k += 1; 7062 } 7063 7064 if (str[k] == 'm') 7065 { 7066 if (R != NULL) 7067 *R = (-(LONGEST) (RU - 1)) - 1; 7068 k += 1; 7069 } 7070 else if (R != NULL) 7071 *R = (LONGEST) RU; 7072 7073 /* NOTE on the above: Technically, C does not say what the results of 7074 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive 7075 number representable as a LONGEST (although either would probably work 7076 in most implementations). When RU>0, the locution in the then branch 7077 above is always equivalent to the negative of RU. */ 7078 7079 if (new_k != NULL) 7080 *new_k = k; 7081 return 1; 7082} 7083 7084/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field), 7085 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is 7086 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */ 7087 7088int 7089ada_in_variant (LONGEST val, struct type *type, int field_num) 7090{ 7091 const char *name = TYPE_FIELD_NAME (type, field_num); 7092 int p; 7093 7094 p = 0; 7095 while (1) 7096 { 7097 switch (name[p]) 7098 { 7099 case '\0': 7100 return 0; 7101 case 'S': 7102 { 7103 LONGEST W; 7104 7105 if (!ada_scan_number (name, p + 1, &W, &p)) 7106 return 0; 7107 if (val == W) 7108 return 1; 7109 break; 7110 } 7111 case 'R': 7112 { 7113 LONGEST L, U; 7114 7115 if (!ada_scan_number (name, p + 1, &L, &p) 7116 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p)) 7117 return 0; 7118 if (val >= L && val <= U) 7119 return 1; 7120 break; 7121 } 7122 case 'O': 7123 return 1; 7124 default: 7125 return 0; 7126 } 7127 } 7128} 7129 7130/* FIXME: Lots of redundancy below. Try to consolidate. */ 7131 7132/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type 7133 ARG_TYPE, extract and return the value of one of its (non-static) 7134 fields. FIELDNO says which field. Differs from value_primitive_field 7135 only in that it can handle packed values of arbitrary type. */ 7136 7137static struct value * 7138ada_value_primitive_field (struct value *arg1, int offset, int fieldno, 7139 struct type *arg_type) 7140{ 7141 struct type *type; 7142 7143 arg_type = ada_check_typedef (arg_type); 7144 type = TYPE_FIELD_TYPE (arg_type, fieldno); 7145 7146 /* Handle packed fields. */ 7147 7148 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0) 7149 { 7150 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno); 7151 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno); 7152 7153 return ada_value_primitive_packed_val (arg1, value_contents (arg1), 7154 offset + bit_pos / 8, 7155 bit_pos % 8, bit_size, type); 7156 } 7157 else 7158 return value_primitive_field (arg1, offset, fieldno, arg_type); 7159} 7160 7161/* Find field with name NAME in object of type TYPE. If found, 7162 set the following for each argument that is non-null: 7163 - *FIELD_TYPE_P to the field's type; 7164 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 7165 an object of that type; 7166 - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 7167 - *BIT_SIZE_P to its size in bits if the field is packed, and 7168 0 otherwise; 7169 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible 7170 fields up to but not including the desired field, or by the total 7171 number of fields if not found. A NULL value of NAME never 7172 matches; the function just counts visible fields in this case. 7173 7174 Notice that we need to handle when a tagged record hierarchy 7175 has some components with the same name, like in this scenario: 7176 7177 type Top_T is tagged record 7178 N : Integer := 1; 7179 U : Integer := 974; 7180 A : Integer := 48; 7181 end record; 7182 7183 type Middle_T is new Top.Top_T with record 7184 N : Character := 'a'; 7185 C : Integer := 3; 7186 end record; 7187 7188 type Bottom_T is new Middle.Middle_T with record 7189 N : Float := 4.0; 7190 C : Character := '5'; 7191 X : Integer := 6; 7192 A : Character := 'J'; 7193 end record; 7194 7195 Let's say we now have a variable declared and initialized as follow: 7196 7197 TC : Top_A := new Bottom_T; 7198 7199 And then we use this variable to call this function 7200 7201 procedure Assign (Obj: in out Top_T; TV : Integer); 7202 7203 as follow: 7204 7205 Assign (Top_T (B), 12); 7206 7207 Now, we're in the debugger, and we're inside that procedure 7208 then and we want to print the value of obj.c: 7209 7210 Usually, the tagged record or one of the parent type owns the 7211 component to print and there's no issue but in this particular 7212 case, what does it mean to ask for Obj.C? Since the actual 7213 type for object is type Bottom_T, it could mean two things: type 7214 component C from the Middle_T view, but also component C from 7215 Bottom_T. So in that "undefined" case, when the component is 7216 not found in the non-resolved type (which includes all the 7217 components of the parent type), then resolve it and see if we 7218 get better luck once expanded. 7219 7220 In the case of homonyms in the derived tagged type, we don't 7221 guaranty anything, and pick the one that's easiest for us 7222 to program. 7223 7224 Returns 1 if found, 0 otherwise. */ 7225 7226static int 7227find_struct_field (const char *name, struct type *type, int offset, 7228 struct type **field_type_p, 7229 int *byte_offset_p, int *bit_offset_p, int *bit_size_p, 7230 int *index_p) 7231{ 7232 int i; 7233 int parent_offset = -1; 7234 7235 type = ada_check_typedef (type); 7236 7237 if (field_type_p != NULL) 7238 *field_type_p = NULL; 7239 if (byte_offset_p != NULL) 7240 *byte_offset_p = 0; 7241 if (bit_offset_p != NULL) 7242 *bit_offset_p = 0; 7243 if (bit_size_p != NULL) 7244 *bit_size_p = 0; 7245 7246 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 7247 { 7248 int bit_pos = TYPE_FIELD_BITPOS (type, i); 7249 int fld_offset = offset + bit_pos / 8; 7250 const char *t_field_name = TYPE_FIELD_NAME (type, i); 7251 7252 if (t_field_name == NULL) 7253 continue; 7254 7255 else if (ada_is_parent_field (type, i)) 7256 { 7257 /* This is a field pointing us to the parent type of a tagged 7258 type. As hinted in this function's documentation, we give 7259 preference to fields in the current record first, so what 7260 we do here is just record the index of this field before 7261 we skip it. If it turns out we couldn't find our field 7262 in the current record, then we'll get back to it and search 7263 inside it whether the field might exist in the parent. */ 7264 7265 parent_offset = i; 7266 continue; 7267 } 7268 7269 else if (name != NULL && field_name_match (t_field_name, name)) 7270 { 7271 int bit_size = TYPE_FIELD_BITSIZE (type, i); 7272 7273 if (field_type_p != NULL) 7274 *field_type_p = TYPE_FIELD_TYPE (type, i); 7275 if (byte_offset_p != NULL) 7276 *byte_offset_p = fld_offset; 7277 if (bit_offset_p != NULL) 7278 *bit_offset_p = bit_pos % 8; 7279 if (bit_size_p != NULL) 7280 *bit_size_p = bit_size; 7281 return 1; 7282 } 7283 else if (ada_is_wrapper_field (type, i)) 7284 { 7285 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset, 7286 field_type_p, byte_offset_p, bit_offset_p, 7287 bit_size_p, index_p)) 7288 return 1; 7289 } 7290 else if (ada_is_variant_part (type, i)) 7291 { 7292 /* PNH: Wait. Do we ever execute this section, or is ARG always of 7293 fixed type?? */ 7294 int j; 7295 struct type *field_type 7296 = ada_check_typedef (TYPE_FIELD_TYPE (type, i)); 7297 7298 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1) 7299 { 7300 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j), 7301 fld_offset 7302 + TYPE_FIELD_BITPOS (field_type, j) / 8, 7303 field_type_p, byte_offset_p, 7304 bit_offset_p, bit_size_p, index_p)) 7305 return 1; 7306 } 7307 } 7308 else if (index_p != NULL) 7309 *index_p += 1; 7310 } 7311 7312 /* Field not found so far. If this is a tagged type which 7313 has a parent, try finding that field in the parent now. */ 7314 7315 if (parent_offset != -1) 7316 { 7317 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset); 7318 int fld_offset = offset + bit_pos / 8; 7319 7320 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset), 7321 fld_offset, field_type_p, byte_offset_p, 7322 bit_offset_p, bit_size_p, index_p)) 7323 return 1; 7324 } 7325 7326 return 0; 7327} 7328 7329/* Number of user-visible fields in record type TYPE. */ 7330 7331static int 7332num_visible_fields (struct type *type) 7333{ 7334 int n; 7335 7336 n = 0; 7337 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n); 7338 return n; 7339} 7340 7341/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes, 7342 and search in it assuming it has (class) type TYPE. 7343 If found, return value, else return NULL. 7344 7345 Searches recursively through wrapper fields (e.g., '_parent'). 7346 7347 In the case of homonyms in the tagged types, please refer to the 7348 long explanation in find_struct_field's function documentation. */ 7349 7350static struct value * 7351ada_search_struct_field (const char *name, struct value *arg, int offset, 7352 struct type *type) 7353{ 7354 int i; 7355 int parent_offset = -1; 7356 7357 type = ada_check_typedef (type); 7358 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 7359 { 7360 const char *t_field_name = TYPE_FIELD_NAME (type, i); 7361 7362 if (t_field_name == NULL) 7363 continue; 7364 7365 else if (ada_is_parent_field (type, i)) 7366 { 7367 /* This is a field pointing us to the parent type of a tagged 7368 type. As hinted in this function's documentation, we give 7369 preference to fields in the current record first, so what 7370 we do here is just record the index of this field before 7371 we skip it. If it turns out we couldn't find our field 7372 in the current record, then we'll get back to it and search 7373 inside it whether the field might exist in the parent. */ 7374 7375 parent_offset = i; 7376 continue; 7377 } 7378 7379 else if (field_name_match (t_field_name, name)) 7380 return ada_value_primitive_field (arg, offset, i, type); 7381 7382 else if (ada_is_wrapper_field (type, i)) 7383 { 7384 struct value *v = /* Do not let indent join lines here. */ 7385 ada_search_struct_field (name, arg, 7386 offset + TYPE_FIELD_BITPOS (type, i) / 8, 7387 TYPE_FIELD_TYPE (type, i)); 7388 7389 if (v != NULL) 7390 return v; 7391 } 7392 7393 else if (ada_is_variant_part (type, i)) 7394 { 7395 /* PNH: Do we ever get here? See find_struct_field. */ 7396 int j; 7397 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, 7398 i)); 7399 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8; 7400 7401 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1) 7402 { 7403 struct value *v = ada_search_struct_field /* Force line 7404 break. */ 7405 (name, arg, 7406 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8, 7407 TYPE_FIELD_TYPE (field_type, j)); 7408 7409 if (v != NULL) 7410 return v; 7411 } 7412 } 7413 } 7414 7415 /* Field not found so far. If this is a tagged type which 7416 has a parent, try finding that field in the parent now. */ 7417 7418 if (parent_offset != -1) 7419 { 7420 struct value *v = ada_search_struct_field ( 7421 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8, 7422 TYPE_FIELD_TYPE (type, parent_offset)); 7423 7424 if (v != NULL) 7425 return v; 7426 } 7427 7428 return NULL; 7429} 7430 7431static struct value *ada_index_struct_field_1 (int *, struct value *, 7432 int, struct type *); 7433 7434 7435/* Return field #INDEX in ARG, where the index is that returned by 7436 * find_struct_field through its INDEX_P argument. Adjust the address 7437 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE. 7438 * If found, return value, else return NULL. */ 7439 7440static struct value * 7441ada_index_struct_field (int index, struct value *arg, int offset, 7442 struct type *type) 7443{ 7444 return ada_index_struct_field_1 (&index, arg, offset, type); 7445} 7446 7447 7448/* Auxiliary function for ada_index_struct_field. Like 7449 * ada_index_struct_field, but takes index from *INDEX_P and modifies 7450 * *INDEX_P. */ 7451 7452static struct value * 7453ada_index_struct_field_1 (int *index_p, struct value *arg, int offset, 7454 struct type *type) 7455{ 7456 int i; 7457 type = ada_check_typedef (type); 7458 7459 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 7460 { 7461 if (TYPE_FIELD_NAME (type, i) == NULL) 7462 continue; 7463 else if (ada_is_wrapper_field (type, i)) 7464 { 7465 struct value *v = /* Do not let indent join lines here. */ 7466 ada_index_struct_field_1 (index_p, arg, 7467 offset + TYPE_FIELD_BITPOS (type, i) / 8, 7468 TYPE_FIELD_TYPE (type, i)); 7469 7470 if (v != NULL) 7471 return v; 7472 } 7473 7474 else if (ada_is_variant_part (type, i)) 7475 { 7476 /* PNH: Do we ever get here? See ada_search_struct_field, 7477 find_struct_field. */ 7478 error (_("Cannot assign this kind of variant record")); 7479 } 7480 else if (*index_p == 0) 7481 return ada_value_primitive_field (arg, offset, i, type); 7482 else 7483 *index_p -= 1; 7484 } 7485 return NULL; 7486} 7487 7488/* Given ARG, a value of type (pointer or reference to a)* 7489 structure/union, extract the component named NAME from the ultimate 7490 target structure/union and return it as a value with its 7491 appropriate type. 7492 7493 The routine searches for NAME among all members of the structure itself 7494 and (recursively) among all members of any wrapper members 7495 (e.g., '_parent'). 7496 7497 If NO_ERR, then simply return NULL in case of error, rather than 7498 calling error. */ 7499 7500struct value * 7501ada_value_struct_elt (struct value *arg, const char *name, int no_err) 7502{ 7503 struct type *t, *t1; 7504 struct value *v; 7505 int check_tag; 7506 7507 v = NULL; 7508 t1 = t = ada_check_typedef (value_type (arg)); 7509 if (TYPE_CODE (t) == TYPE_CODE_REF) 7510 { 7511 t1 = TYPE_TARGET_TYPE (t); 7512 if (t1 == NULL) 7513 goto BadValue; 7514 t1 = ada_check_typedef (t1); 7515 if (TYPE_CODE (t1) == TYPE_CODE_PTR) 7516 { 7517 arg = coerce_ref (arg); 7518 t = t1; 7519 } 7520 } 7521 7522 while (TYPE_CODE (t) == TYPE_CODE_PTR) 7523 { 7524 t1 = TYPE_TARGET_TYPE (t); 7525 if (t1 == NULL) 7526 goto BadValue; 7527 t1 = ada_check_typedef (t1); 7528 if (TYPE_CODE (t1) == TYPE_CODE_PTR) 7529 { 7530 arg = value_ind (arg); 7531 t = t1; 7532 } 7533 else 7534 break; 7535 } 7536 7537 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION) 7538 goto BadValue; 7539 7540 if (t1 == t) 7541 v = ada_search_struct_field (name, arg, 0, t); 7542 else 7543 { 7544 int bit_offset, bit_size, byte_offset; 7545 struct type *field_type; 7546 CORE_ADDR address; 7547 7548 if (TYPE_CODE (t) == TYPE_CODE_PTR) 7549 address = value_address (ada_value_ind (arg)); 7550 else 7551 address = value_address (ada_coerce_ref (arg)); 7552 7553 /* Check to see if this is a tagged type. We also need to handle 7554 the case where the type is a reference to a tagged type, but 7555 we have to be careful to exclude pointers to tagged types. 7556 The latter should be shown as usual (as a pointer), whereas 7557 a reference should mostly be transparent to the user. */ 7558 7559 if (ada_is_tagged_type (t1, 0) 7560 || (TYPE_CODE (t1) == TYPE_CODE_REF 7561 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0))) 7562 { 7563 /* We first try to find the searched field in the current type. 7564 If not found then let's look in the fixed type. */ 7565 7566 if (!find_struct_field (name, t1, 0, 7567 &field_type, &byte_offset, &bit_offset, 7568 &bit_size, NULL)) 7569 check_tag = 1; 7570 else 7571 check_tag = 0; 7572 } 7573 else 7574 check_tag = 0; 7575 7576 /* Convert to fixed type in all cases, so that we have proper 7577 offsets to each field in unconstrained record types. */ 7578 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, 7579 address, NULL, check_tag); 7580 7581 if (find_struct_field (name, t1, 0, 7582 &field_type, &byte_offset, &bit_offset, 7583 &bit_size, NULL)) 7584 { 7585 if (bit_size != 0) 7586 { 7587 if (TYPE_CODE (t) == TYPE_CODE_REF) 7588 arg = ada_coerce_ref (arg); 7589 else 7590 arg = ada_value_ind (arg); 7591 v = ada_value_primitive_packed_val (arg, NULL, byte_offset, 7592 bit_offset, bit_size, 7593 field_type); 7594 } 7595 else 7596 v = value_at_lazy (field_type, address + byte_offset); 7597 } 7598 } 7599 7600 if (v != NULL || no_err) 7601 return v; 7602 else 7603 error (_("There is no member named %s."), name); 7604 7605 BadValue: 7606 if (no_err) 7607 return NULL; 7608 else 7609 error (_("Attempt to extract a component of " 7610 "a value that is not a record.")); 7611} 7612 7613/* Return a string representation of type TYPE. */ 7614 7615static std::string 7616type_as_string (struct type *type) 7617{ 7618 string_file tmp_stream; 7619 7620 type_print (type, "", &tmp_stream, -1); 7621 7622 return std::move (tmp_stream.string ()); 7623} 7624 7625/* Given a type TYPE, look up the type of the component of type named NAME. 7626 If DISPP is non-null, add its byte displacement from the beginning of a 7627 structure (pointed to by a value) of type TYPE to *DISPP (does not 7628 work for packed fields). 7629 7630 Matches any field whose name has NAME as a prefix, possibly 7631 followed by "___". 7632 7633 TYPE can be either a struct or union. If REFOK, TYPE may also 7634 be a (pointer or reference)+ to a struct or union, and the 7635 ultimate target type will be searched. 7636 7637 Looks recursively into variant clauses and parent types. 7638 7639 In the case of homonyms in the tagged types, please refer to the 7640 long explanation in find_struct_field's function documentation. 7641 7642 If NOERR is nonzero, return NULL if NAME is not suitably defined or 7643 TYPE is not a type of the right kind. */ 7644 7645static struct type * 7646ada_lookup_struct_elt_type (struct type *type, const char *name, int refok, 7647 int noerr) 7648{ 7649 int i; 7650 int parent_offset = -1; 7651 7652 if (name == NULL) 7653 goto BadName; 7654 7655 if (refok && type != NULL) 7656 while (1) 7657 { 7658 type = ada_check_typedef (type); 7659 if (TYPE_CODE (type) != TYPE_CODE_PTR 7660 && TYPE_CODE (type) != TYPE_CODE_REF) 7661 break; 7662 type = TYPE_TARGET_TYPE (type); 7663 } 7664 7665 if (type == NULL 7666 || (TYPE_CODE (type) != TYPE_CODE_STRUCT 7667 && TYPE_CODE (type) != TYPE_CODE_UNION)) 7668 { 7669 if (noerr) 7670 return NULL; 7671 7672 error (_("Type %s is not a structure or union type"), 7673 type != NULL ? type_as_string (type).c_str () : _("(null)")); 7674 } 7675 7676 type = to_static_fixed_type (type); 7677 7678 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 7679 { 7680 const char *t_field_name = TYPE_FIELD_NAME (type, i); 7681 struct type *t; 7682 7683 if (t_field_name == NULL) 7684 continue; 7685 7686 else if (ada_is_parent_field (type, i)) 7687 { 7688 /* This is a field pointing us to the parent type of a tagged 7689 type. As hinted in this function's documentation, we give 7690 preference to fields in the current record first, so what 7691 we do here is just record the index of this field before 7692 we skip it. If it turns out we couldn't find our field 7693 in the current record, then we'll get back to it and search 7694 inside it whether the field might exist in the parent. */ 7695 7696 parent_offset = i; 7697 continue; 7698 } 7699 7700 else if (field_name_match (t_field_name, name)) 7701 return TYPE_FIELD_TYPE (type, i); 7702 7703 else if (ada_is_wrapper_field (type, i)) 7704 { 7705 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name, 7706 0, 1); 7707 if (t != NULL) 7708 return t; 7709 } 7710 7711 else if (ada_is_variant_part (type, i)) 7712 { 7713 int j; 7714 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, 7715 i)); 7716 7717 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1) 7718 { 7719 /* FIXME pnh 2008/01/26: We check for a field that is 7720 NOT wrapped in a struct, since the compiler sometimes 7721 generates these for unchecked variant types. Revisit 7722 if the compiler changes this practice. */ 7723 const char *v_field_name = TYPE_FIELD_NAME (field_type, j); 7724 7725 if (v_field_name != NULL 7726 && field_name_match (v_field_name, name)) 7727 t = TYPE_FIELD_TYPE (field_type, j); 7728 else 7729 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, 7730 j), 7731 name, 0, 1); 7732 7733 if (t != NULL) 7734 return t; 7735 } 7736 } 7737 7738 } 7739 7740 /* Field not found so far. If this is a tagged type which 7741 has a parent, try finding that field in the parent now. */ 7742 7743 if (parent_offset != -1) 7744 { 7745 struct type *t; 7746 7747 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset), 7748 name, 0, 1); 7749 if (t != NULL) 7750 return t; 7751 } 7752 7753BadName: 7754 if (!noerr) 7755 { 7756 const char *name_str = name != NULL ? name : _("<null>"); 7757 7758 error (_("Type %s has no component named %s"), 7759 type_as_string (type).c_str (), name_str); 7760 } 7761 7762 return NULL; 7763} 7764 7765/* Assuming that VAR_TYPE is the type of a variant part of a record (a union), 7766 within a value of type OUTER_TYPE, return true iff VAR_TYPE 7767 represents an unchecked union (that is, the variant part of a 7768 record that is named in an Unchecked_Union pragma). */ 7769 7770static int 7771is_unchecked_variant (struct type *var_type, struct type *outer_type) 7772{ 7773 const char *discrim_name = ada_variant_discrim_name (var_type); 7774 7775 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL); 7776} 7777 7778 7779/* Assuming that VAR_TYPE is the type of a variant part of a record (a union), 7780 within a value of type OUTER_TYPE that is stored in GDB at 7781 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE, 7782 numbering from 0) is applicable. Returns -1 if none are. */ 7783 7784int 7785ada_which_variant_applies (struct type *var_type, struct type *outer_type, 7786 const gdb_byte *outer_valaddr) 7787{ 7788 int others_clause; 7789 int i; 7790 const char *discrim_name = ada_variant_discrim_name (var_type); 7791 struct value *outer; 7792 struct value *discrim; 7793 LONGEST discrim_val; 7794 7795 /* Using plain value_from_contents_and_address here causes problems 7796 because we will end up trying to resolve a type that is currently 7797 being constructed. */ 7798 outer = value_from_contents_and_address_unresolved (outer_type, 7799 outer_valaddr, 0); 7800 discrim = ada_value_struct_elt (outer, discrim_name, 1); 7801 if (discrim == NULL) 7802 return -1; 7803 discrim_val = value_as_long (discrim); 7804 7805 others_clause = -1; 7806 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1) 7807 { 7808 if (ada_is_others_clause (var_type, i)) 7809 others_clause = i; 7810 else if (ada_in_variant (discrim_val, var_type, i)) 7811 return i; 7812 } 7813 7814 return others_clause; 7815} 7816 7817 7818 7819 /* Dynamic-Sized Records */ 7820 7821/* Strategy: The type ostensibly attached to a value with dynamic size 7822 (i.e., a size that is not statically recorded in the debugging 7823 data) does not accurately reflect the size or layout of the value. 7824 Our strategy is to convert these values to values with accurate, 7825 conventional types that are constructed on the fly. */ 7826 7827/* There is a subtle and tricky problem here. In general, we cannot 7828 determine the size of dynamic records without its data. However, 7829 the 'struct value' data structure, which GDB uses to represent 7830 quantities in the inferior process (the target), requires the size 7831 of the type at the time of its allocation in order to reserve space 7832 for GDB's internal copy of the data. That's why the 7833 'to_fixed_xxx_type' routines take (target) addresses as parameters, 7834 rather than struct value*s. 7835 7836 However, GDB's internal history variables ($1, $2, etc.) are 7837 struct value*s containing internal copies of the data that are not, in 7838 general, the same as the data at their corresponding addresses in 7839 the target. Fortunately, the types we give to these values are all 7840 conventional, fixed-size types (as per the strategy described 7841 above), so that we don't usually have to perform the 7842 'to_fixed_xxx_type' conversions to look at their values. 7843 Unfortunately, there is one exception: if one of the internal 7844 history variables is an array whose elements are unconstrained 7845 records, then we will need to create distinct fixed types for each 7846 element selected. */ 7847 7848/* The upshot of all of this is that many routines take a (type, host 7849 address, target address) triple as arguments to represent a value. 7850 The host address, if non-null, is supposed to contain an internal 7851 copy of the relevant data; otherwise, the program is to consult the 7852 target at the target address. */ 7853 7854/* Assuming that VAL0 represents a pointer value, the result of 7855 dereferencing it. Differs from value_ind in its treatment of 7856 dynamic-sized types. */ 7857 7858struct value * 7859ada_value_ind (struct value *val0) 7860{ 7861 struct value *val = value_ind (val0); 7862 7863 if (ada_is_tagged_type (value_type (val), 0)) 7864 val = ada_tag_value_at_base_address (val); 7865 7866 return ada_to_fixed_value (val); 7867} 7868 7869/* The value resulting from dereferencing any "reference to" 7870 qualifiers on VAL0. */ 7871 7872static struct value * 7873ada_coerce_ref (struct value *val0) 7874{ 7875 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF) 7876 { 7877 struct value *val = val0; 7878 7879 val = coerce_ref (val); 7880 7881 if (ada_is_tagged_type (value_type (val), 0)) 7882 val = ada_tag_value_at_base_address (val); 7883 7884 return ada_to_fixed_value (val); 7885 } 7886 else 7887 return val0; 7888} 7889 7890/* Return OFF rounded upward if necessary to a multiple of 7891 ALIGNMENT (a power of 2). */ 7892 7893static unsigned int 7894align_value (unsigned int off, unsigned int alignment) 7895{ 7896 return (off + alignment - 1) & ~(alignment - 1); 7897} 7898 7899/* Return the bit alignment required for field #F of template type TYPE. */ 7900 7901static unsigned int 7902field_alignment (struct type *type, int f) 7903{ 7904 const char *name = TYPE_FIELD_NAME (type, f); 7905 int len; 7906 int align_offset; 7907 7908 /* The field name should never be null, unless the debugging information 7909 is somehow malformed. In this case, we assume the field does not 7910 require any alignment. */ 7911 if (name == NULL) 7912 return 1; 7913 7914 len = strlen (name); 7915 7916 if (!isdigit (name[len - 1])) 7917 return 1; 7918 7919 if (isdigit (name[len - 2])) 7920 align_offset = len - 2; 7921 else 7922 align_offset = len - 1; 7923 7924 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV")) 7925 return TARGET_CHAR_BIT; 7926 7927 return atoi (name + align_offset) * TARGET_CHAR_BIT; 7928} 7929 7930/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */ 7931 7932static struct symbol * 7933ada_find_any_type_symbol (const char *name) 7934{ 7935 struct symbol *sym; 7936 7937 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN); 7938 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF) 7939 return sym; 7940 7941 sym = standard_lookup (name, NULL, STRUCT_DOMAIN); 7942 return sym; 7943} 7944 7945/* Find a type named NAME. Ignores ambiguity. This routine will look 7946 solely for types defined by debug info, it will not search the GDB 7947 primitive types. */ 7948 7949static struct type * 7950ada_find_any_type (const char *name) 7951{ 7952 struct symbol *sym = ada_find_any_type_symbol (name); 7953 7954 if (sym != NULL) 7955 return SYMBOL_TYPE (sym); 7956 7957 return NULL; 7958} 7959 7960/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol 7961 associated with NAME_SYM's name. NAME_SYM may itself be a renaming 7962 symbol, in which case it is returned. Otherwise, this looks for 7963 symbols whose name is that of NAME_SYM suffixed with "___XR". 7964 Return symbol if found, and NULL otherwise. */ 7965 7966struct symbol * 7967ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block) 7968{ 7969 const char *name = SYMBOL_LINKAGE_NAME (name_sym); 7970 struct symbol *sym; 7971 7972 if (strstr (name, "___XR") != NULL) 7973 return name_sym; 7974 7975 sym = find_old_style_renaming_symbol (name, block); 7976 7977 if (sym != NULL) 7978 return sym; 7979 7980 /* Not right yet. FIXME pnh 7/20/2007. */ 7981 sym = ada_find_any_type_symbol (name); 7982 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL) 7983 return sym; 7984 else 7985 return NULL; 7986} 7987 7988static struct symbol * 7989find_old_style_renaming_symbol (const char *name, const struct block *block) 7990{ 7991 const struct symbol *function_sym = block_linkage_function (block); 7992 char *rename; 7993 7994 if (function_sym != NULL) 7995 { 7996 /* If the symbol is defined inside a function, NAME is not fully 7997 qualified. This means we need to prepend the function name 7998 as well as adding the ``___XR'' suffix to build the name of 7999 the associated renaming symbol. */ 8000 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym); 8001 /* Function names sometimes contain suffixes used 8002 for instance to qualify nested subprograms. When building 8003 the XR type name, we need to make sure that this suffix is 8004 not included. So do not include any suffix in the function 8005 name length below. */ 8006 int function_name_len = ada_name_prefix_len (function_name); 8007 const int rename_len = function_name_len + 2 /* "__" */ 8008 + strlen (name) + 6 /* "___XR\0" */ ; 8009 8010 /* Strip the suffix if necessary. */ 8011 ada_remove_trailing_digits (function_name, &function_name_len); 8012 ada_remove_po_subprogram_suffix (function_name, &function_name_len); 8013 ada_remove_Xbn_suffix (function_name, &function_name_len); 8014 8015 /* Library-level functions are a special case, as GNAT adds 8016 a ``_ada_'' prefix to the function name to avoid namespace 8017 pollution. However, the renaming symbols themselves do not 8018 have this prefix, so we need to skip this prefix if present. */ 8019 if (function_name_len > 5 /* "_ada_" */ 8020 && strstr (function_name, "_ada_") == function_name) 8021 { 8022 function_name += 5; 8023 function_name_len -= 5; 8024 } 8025 8026 rename = (char *) alloca (rename_len * sizeof (char)); 8027 strncpy (rename, function_name, function_name_len); 8028 xsnprintf (rename + function_name_len, rename_len - function_name_len, 8029 "__%s___XR", name); 8030 } 8031 else 8032 { 8033 const int rename_len = strlen (name) + 6; 8034 8035 rename = (char *) alloca (rename_len * sizeof (char)); 8036 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name); 8037 } 8038 8039 return ada_find_any_type_symbol (rename); 8040} 8041 8042/* Because of GNAT encoding conventions, several GDB symbols may match a 8043 given type name. If the type denoted by TYPE0 is to be preferred to 8044 that of TYPE1 for purposes of type printing, return non-zero; 8045 otherwise return 0. */ 8046 8047int 8048ada_prefer_type (struct type *type0, struct type *type1) 8049{ 8050 if (type1 == NULL) 8051 return 1; 8052 else if (type0 == NULL) 8053 return 0; 8054 else if (TYPE_CODE (type1) == TYPE_CODE_VOID) 8055 return 1; 8056 else if (TYPE_CODE (type0) == TYPE_CODE_VOID) 8057 return 0; 8058 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL) 8059 return 1; 8060 else if (ada_is_constrained_packed_array_type (type0)) 8061 return 1; 8062 else if (ada_is_array_descriptor_type (type0) 8063 && !ada_is_array_descriptor_type (type1)) 8064 return 1; 8065 else 8066 { 8067 const char *type0_name = TYPE_NAME (type0); 8068 const char *type1_name = TYPE_NAME (type1); 8069 8070 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL 8071 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL)) 8072 return 1; 8073 } 8074 return 0; 8075} 8076 8077/* The name of TYPE, which is its TYPE_NAME. Null if TYPE is 8078 null. */ 8079 8080const char * 8081ada_type_name (struct type *type) 8082{ 8083 if (type == NULL) 8084 return NULL; 8085 return TYPE_NAME (type); 8086} 8087 8088/* Search the list of "descriptive" types associated to TYPE for a type 8089 whose name is NAME. */ 8090 8091static struct type * 8092find_parallel_type_by_descriptive_type (struct type *type, const char *name) 8093{ 8094 struct type *result, *tmp; 8095 8096 if (ada_ignore_descriptive_types_p) 8097 return NULL; 8098 8099 /* If there no descriptive-type info, then there is no parallel type 8100 to be found. */ 8101 if (!HAVE_GNAT_AUX_INFO (type)) 8102 return NULL; 8103 8104 result = TYPE_DESCRIPTIVE_TYPE (type); 8105 while (result != NULL) 8106 { 8107 const char *result_name = ada_type_name (result); 8108 8109 if (result_name == NULL) 8110 { 8111 warning (_("unexpected null name on descriptive type")); 8112 return NULL; 8113 } 8114 8115 /* If the names match, stop. */ 8116 if (strcmp (result_name, name) == 0) 8117 break; 8118 8119 /* Otherwise, look at the next item on the list, if any. */ 8120 if (HAVE_GNAT_AUX_INFO (result)) 8121 tmp = TYPE_DESCRIPTIVE_TYPE (result); 8122 else 8123 tmp = NULL; 8124 8125 /* If not found either, try after having resolved the typedef. */ 8126 if (tmp != NULL) 8127 result = tmp; 8128 else 8129 { 8130 result = check_typedef (result); 8131 if (HAVE_GNAT_AUX_INFO (result)) 8132 result = TYPE_DESCRIPTIVE_TYPE (result); 8133 else 8134 result = NULL; 8135 } 8136 } 8137 8138 /* If we didn't find a match, see whether this is a packed array. With 8139 older compilers, the descriptive type information is either absent or 8140 irrelevant when it comes to packed arrays so the above lookup fails. 8141 Fall back to using a parallel lookup by name in this case. */ 8142 if (result == NULL && ada_is_constrained_packed_array_type (type)) 8143 return ada_find_any_type (name); 8144 8145 return result; 8146} 8147 8148/* Find a parallel type to TYPE with the specified NAME, using the 8149 descriptive type taken from the debugging information, if available, 8150 and otherwise using the (slower) name-based method. */ 8151 8152static struct type * 8153ada_find_parallel_type_with_name (struct type *type, const char *name) 8154{ 8155 struct type *result = NULL; 8156 8157 if (HAVE_GNAT_AUX_INFO (type)) 8158 result = find_parallel_type_by_descriptive_type (type, name); 8159 else 8160 result = ada_find_any_type (name); 8161 8162 return result; 8163} 8164 8165/* Same as above, but specify the name of the parallel type by appending 8166 SUFFIX to the name of TYPE. */ 8167 8168struct type * 8169ada_find_parallel_type (struct type *type, const char *suffix) 8170{ 8171 char *name; 8172 const char *type_name = ada_type_name (type); 8173 int len; 8174 8175 if (type_name == NULL) 8176 return NULL; 8177 8178 len = strlen (type_name); 8179 8180 name = (char *) alloca (len + strlen (suffix) + 1); 8181 8182 strcpy (name, type_name); 8183 strcpy (name + len, suffix); 8184 8185 return ada_find_parallel_type_with_name (type, name); 8186} 8187 8188/* If TYPE is a variable-size record type, return the corresponding template 8189 type describing its fields. Otherwise, return NULL. */ 8190 8191static struct type * 8192dynamic_template_type (struct type *type) 8193{ 8194 type = ada_check_typedef (type); 8195 8196 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT 8197 || ada_type_name (type) == NULL) 8198 return NULL; 8199 else 8200 { 8201 int len = strlen (ada_type_name (type)); 8202 8203 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0) 8204 return type; 8205 else 8206 return ada_find_parallel_type (type, "___XVE"); 8207 } 8208} 8209 8210/* Assuming that TEMPL_TYPE is a union or struct type, returns 8211 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */ 8212 8213static int 8214is_dynamic_field (struct type *templ_type, int field_num) 8215{ 8216 const char *name = TYPE_FIELD_NAME (templ_type, field_num); 8217 8218 return name != NULL 8219 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR 8220 && strstr (name, "___XVL") != NULL; 8221} 8222 8223/* The index of the variant field of TYPE, or -1 if TYPE does not 8224 represent a variant record type. */ 8225 8226static int 8227variant_field_index (struct type *type) 8228{ 8229 int f; 8230 8231 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT) 8232 return -1; 8233 8234 for (f = 0; f < TYPE_NFIELDS (type); f += 1) 8235 { 8236 if (ada_is_variant_part (type, f)) 8237 return f; 8238 } 8239 return -1; 8240} 8241 8242/* A record type with no fields. */ 8243 8244static struct type * 8245empty_record (struct type *templ) 8246{ 8247 struct type *type = alloc_type_copy (templ); 8248 8249 TYPE_CODE (type) = TYPE_CODE_STRUCT; 8250 TYPE_NFIELDS (type) = 0; 8251 TYPE_FIELDS (type) = NULL; 8252 INIT_CPLUS_SPECIFIC (type); 8253 TYPE_NAME (type) = "<empty>"; 8254 TYPE_LENGTH (type) = 0; 8255 return type; 8256} 8257 8258/* An ordinary record type (with fixed-length fields) that describes 8259 the value of type TYPE at VALADDR or ADDRESS (see comments at 8260 the beginning of this section) VAL according to GNAT conventions. 8261 DVAL0 should describe the (portion of a) record that contains any 8262 necessary discriminants. It should be NULL if value_type (VAL) is 8263 an outer-level type (i.e., as opposed to a branch of a variant.) A 8264 variant field (unless unchecked) is replaced by a particular branch 8265 of the variant. 8266 8267 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or 8268 length are not statically known are discarded. As a consequence, 8269 VALADDR, ADDRESS and DVAL0 are ignored. 8270 8271 NOTE: Limitations: For now, we assume that dynamic fields and 8272 variants occupy whole numbers of bytes. However, they need not be 8273 byte-aligned. */ 8274 8275struct type * 8276ada_template_to_fixed_record_type_1 (struct type *type, 8277 const gdb_byte *valaddr, 8278 CORE_ADDR address, struct value *dval0, 8279 int keep_dynamic_fields) 8280{ 8281 struct value *mark = value_mark (); 8282 struct value *dval; 8283 struct type *rtype; 8284 int nfields, bit_len; 8285 int variant_field; 8286 long off; 8287 int fld_bit_len; 8288 int f; 8289 8290 /* Compute the number of fields in this record type that are going 8291 to be processed: unless keep_dynamic_fields, this includes only 8292 fields whose position and length are static will be processed. */ 8293 if (keep_dynamic_fields) 8294 nfields = TYPE_NFIELDS (type); 8295 else 8296 { 8297 nfields = 0; 8298 while (nfields < TYPE_NFIELDS (type) 8299 && !ada_is_variant_part (type, nfields) 8300 && !is_dynamic_field (type, nfields)) 8301 nfields++; 8302 } 8303 8304 rtype = alloc_type_copy (type); 8305 TYPE_CODE (rtype) = TYPE_CODE_STRUCT; 8306 INIT_CPLUS_SPECIFIC (rtype); 8307 TYPE_NFIELDS (rtype) = nfields; 8308 TYPE_FIELDS (rtype) = (struct field *) 8309 TYPE_ALLOC (rtype, nfields * sizeof (struct field)); 8310 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields); 8311 TYPE_NAME (rtype) = ada_type_name (type); 8312 TYPE_FIXED_INSTANCE (rtype) = 1; 8313 8314 off = 0; 8315 bit_len = 0; 8316 variant_field = -1; 8317 8318 for (f = 0; f < nfields; f += 1) 8319 { 8320 off = align_value (off, field_alignment (type, f)) 8321 + TYPE_FIELD_BITPOS (type, f); 8322 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off); 8323 TYPE_FIELD_BITSIZE (rtype, f) = 0; 8324 8325 if (ada_is_variant_part (type, f)) 8326 { 8327 variant_field = f; 8328 fld_bit_len = 0; 8329 } 8330 else if (is_dynamic_field (type, f)) 8331 { 8332 const gdb_byte *field_valaddr = valaddr; 8333 CORE_ADDR field_address = address; 8334 struct type *field_type = 8335 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f)); 8336 8337 if (dval0 == NULL) 8338 { 8339 /* rtype's length is computed based on the run-time 8340 value of discriminants. If the discriminants are not 8341 initialized, the type size may be completely bogus and 8342 GDB may fail to allocate a value for it. So check the 8343 size first before creating the value. */ 8344 ada_ensure_varsize_limit (rtype); 8345 /* Using plain value_from_contents_and_address here 8346 causes problems because we will end up trying to 8347 resolve a type that is currently being 8348 constructed. */ 8349 dval = value_from_contents_and_address_unresolved (rtype, 8350 valaddr, 8351 address); 8352 rtype = value_type (dval); 8353 } 8354 else 8355 dval = dval0; 8356 8357 /* If the type referenced by this field is an aligner type, we need 8358 to unwrap that aligner type, because its size might not be set. 8359 Keeping the aligner type would cause us to compute the wrong 8360 size for this field, impacting the offset of the all the fields 8361 that follow this one. */ 8362 if (ada_is_aligner_type (field_type)) 8363 { 8364 long field_offset = TYPE_FIELD_BITPOS (field_type, f); 8365 8366 field_valaddr = cond_offset_host (field_valaddr, field_offset); 8367 field_address = cond_offset_target (field_address, field_offset); 8368 field_type = ada_aligned_type (field_type); 8369 } 8370 8371 field_valaddr = cond_offset_host (field_valaddr, 8372 off / TARGET_CHAR_BIT); 8373 field_address = cond_offset_target (field_address, 8374 off / TARGET_CHAR_BIT); 8375 8376 /* Get the fixed type of the field. Note that, in this case, 8377 we do not want to get the real type out of the tag: if 8378 the current field is the parent part of a tagged record, 8379 we will get the tag of the object. Clearly wrong: the real 8380 type of the parent is not the real type of the child. We 8381 would end up in an infinite loop. */ 8382 field_type = ada_get_base_type (field_type); 8383 field_type = ada_to_fixed_type (field_type, field_valaddr, 8384 field_address, dval, 0); 8385 /* If the field size is already larger than the maximum 8386 object size, then the record itself will necessarily 8387 be larger than the maximum object size. We need to make 8388 this check now, because the size might be so ridiculously 8389 large (due to an uninitialized variable in the inferior) 8390 that it would cause an overflow when adding it to the 8391 record size. */ 8392 ada_ensure_varsize_limit (field_type); 8393 8394 TYPE_FIELD_TYPE (rtype, f) = field_type; 8395 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f); 8396 /* The multiplication can potentially overflow. But because 8397 the field length has been size-checked just above, and 8398 assuming that the maximum size is a reasonable value, 8399 an overflow should not happen in practice. So rather than 8400 adding overflow recovery code to this already complex code, 8401 we just assume that it's not going to happen. */ 8402 fld_bit_len = 8403 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT; 8404 } 8405 else 8406 { 8407 /* Note: If this field's type is a typedef, it is important 8408 to preserve the typedef layer. 8409 8410 Otherwise, we might be transforming a typedef to a fat 8411 pointer (encoding a pointer to an unconstrained array), 8412 into a basic fat pointer (encoding an unconstrained 8413 array). As both types are implemented using the same 8414 structure, the typedef is the only clue which allows us 8415 to distinguish between the two options. Stripping it 8416 would prevent us from printing this field appropriately. */ 8417 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f); 8418 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f); 8419 if (TYPE_FIELD_BITSIZE (type, f) > 0) 8420 fld_bit_len = 8421 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f); 8422 else 8423 { 8424 struct type *field_type = TYPE_FIELD_TYPE (type, f); 8425 8426 /* We need to be careful of typedefs when computing 8427 the length of our field. If this is a typedef, 8428 get the length of the target type, not the length 8429 of the typedef. */ 8430 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF) 8431 field_type = ada_typedef_target_type (field_type); 8432 8433 fld_bit_len = 8434 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT; 8435 } 8436 } 8437 if (off + fld_bit_len > bit_len) 8438 bit_len = off + fld_bit_len; 8439 off += fld_bit_len; 8440 TYPE_LENGTH (rtype) = 8441 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT; 8442 } 8443 8444 /* We handle the variant part, if any, at the end because of certain 8445 odd cases in which it is re-ordered so as NOT to be the last field of 8446 the record. This can happen in the presence of representation 8447 clauses. */ 8448 if (variant_field >= 0) 8449 { 8450 struct type *branch_type; 8451 8452 off = TYPE_FIELD_BITPOS (rtype, variant_field); 8453 8454 if (dval0 == NULL) 8455 { 8456 /* Using plain value_from_contents_and_address here causes 8457 problems because we will end up trying to resolve a type 8458 that is currently being constructed. */ 8459 dval = value_from_contents_and_address_unresolved (rtype, valaddr, 8460 address); 8461 rtype = value_type (dval); 8462 } 8463 else 8464 dval = dval0; 8465 8466 branch_type = 8467 to_fixed_variant_branch_type 8468 (TYPE_FIELD_TYPE (type, variant_field), 8469 cond_offset_host (valaddr, off / TARGET_CHAR_BIT), 8470 cond_offset_target (address, off / TARGET_CHAR_BIT), dval); 8471 if (branch_type == NULL) 8472 { 8473 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1) 8474 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f]; 8475 TYPE_NFIELDS (rtype) -= 1; 8476 } 8477 else 8478 { 8479 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type; 8480 TYPE_FIELD_NAME (rtype, variant_field) = "S"; 8481 fld_bit_len = 8482 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) * 8483 TARGET_CHAR_BIT; 8484 if (off + fld_bit_len > bit_len) 8485 bit_len = off + fld_bit_len; 8486 TYPE_LENGTH (rtype) = 8487 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT; 8488 } 8489 } 8490 8491 /* According to exp_dbug.ads, the size of TYPE for variable-size records 8492 should contain the alignment of that record, which should be a strictly 8493 positive value. If null or negative, then something is wrong, most 8494 probably in the debug info. In that case, we don't round up the size 8495 of the resulting type. If this record is not part of another structure, 8496 the current RTYPE length might be good enough for our purposes. */ 8497 if (TYPE_LENGTH (type) <= 0) 8498 { 8499 if (TYPE_NAME (rtype)) 8500 warning (_("Invalid type size for `%s' detected: %d."), 8501 TYPE_NAME (rtype), TYPE_LENGTH (type)); 8502 else 8503 warning (_("Invalid type size for <unnamed> detected: %d."), 8504 TYPE_LENGTH (type)); 8505 } 8506 else 8507 { 8508 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype), 8509 TYPE_LENGTH (type)); 8510 } 8511 8512 value_free_to_mark (mark); 8513 if (TYPE_LENGTH (rtype) > varsize_limit) 8514 error (_("record type with dynamic size is larger than varsize-limit")); 8515 return rtype; 8516} 8517 8518/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS 8519 of 1. */ 8520 8521static struct type * 8522template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr, 8523 CORE_ADDR address, struct value *dval0) 8524{ 8525 return ada_template_to_fixed_record_type_1 (type, valaddr, 8526 address, dval0, 1); 8527} 8528 8529/* An ordinary record type in which ___XVL-convention fields and 8530 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with 8531 static approximations, containing all possible fields. Uses 8532 no runtime values. Useless for use in values, but that's OK, 8533 since the results are used only for type determinations. Works on both 8534 structs and unions. Representation note: to save space, we memorize 8535 the result of this function in the TYPE_TARGET_TYPE of the 8536 template type. */ 8537 8538static struct type * 8539template_to_static_fixed_type (struct type *type0) 8540{ 8541 struct type *type; 8542 int nfields; 8543 int f; 8544 8545 /* No need no do anything if the input type is already fixed. */ 8546 if (TYPE_FIXED_INSTANCE (type0)) 8547 return type0; 8548 8549 /* Likewise if we already have computed the static approximation. */ 8550 if (TYPE_TARGET_TYPE (type0) != NULL) 8551 return TYPE_TARGET_TYPE (type0); 8552 8553 /* Don't clone TYPE0 until we are sure we are going to need a copy. */ 8554 type = type0; 8555 nfields = TYPE_NFIELDS (type0); 8556 8557 /* Whether or not we cloned TYPE0, cache the result so that we don't do 8558 recompute all over next time. */ 8559 TYPE_TARGET_TYPE (type0) = type; 8560 8561 for (f = 0; f < nfields; f += 1) 8562 { 8563 struct type *field_type = TYPE_FIELD_TYPE (type0, f); 8564 struct type *new_type; 8565 8566 if (is_dynamic_field (type0, f)) 8567 { 8568 field_type = ada_check_typedef (field_type); 8569 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type)); 8570 } 8571 else 8572 new_type = static_unwrap_type (field_type); 8573 8574 if (new_type != field_type) 8575 { 8576 /* Clone TYPE0 only the first time we get a new field type. */ 8577 if (type == type0) 8578 { 8579 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0); 8580 TYPE_CODE (type) = TYPE_CODE (type0); 8581 INIT_CPLUS_SPECIFIC (type); 8582 TYPE_NFIELDS (type) = nfields; 8583 TYPE_FIELDS (type) = (struct field *) 8584 TYPE_ALLOC (type, nfields * sizeof (struct field)); 8585 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0), 8586 sizeof (struct field) * nfields); 8587 TYPE_NAME (type) = ada_type_name (type0); 8588 TYPE_FIXED_INSTANCE (type) = 1; 8589 TYPE_LENGTH (type) = 0; 8590 } 8591 TYPE_FIELD_TYPE (type, f) = new_type; 8592 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f); 8593 } 8594 } 8595 8596 return type; 8597} 8598 8599/* Given an object of type TYPE whose contents are at VALADDR and 8600 whose address in memory is ADDRESS, returns a revision of TYPE, 8601 which should be a non-dynamic-sized record, in which the variant 8602 part, if any, is replaced with the appropriate branch. Looks 8603 for discriminant values in DVAL0, which can be NULL if the record 8604 contains the necessary discriminant values. */ 8605 8606static struct type * 8607to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr, 8608 CORE_ADDR address, struct value *dval0) 8609{ 8610 struct value *mark = value_mark (); 8611 struct value *dval; 8612 struct type *rtype; 8613 struct type *branch_type; 8614 int nfields = TYPE_NFIELDS (type); 8615 int variant_field = variant_field_index (type); 8616 8617 if (variant_field == -1) 8618 return type; 8619 8620 if (dval0 == NULL) 8621 { 8622 dval = value_from_contents_and_address (type, valaddr, address); 8623 type = value_type (dval); 8624 } 8625 else 8626 dval = dval0; 8627 8628 rtype = alloc_type_copy (type); 8629 TYPE_CODE (rtype) = TYPE_CODE_STRUCT; 8630 INIT_CPLUS_SPECIFIC (rtype); 8631 TYPE_NFIELDS (rtype) = nfields; 8632 TYPE_FIELDS (rtype) = 8633 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field)); 8634 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type), 8635 sizeof (struct field) * nfields); 8636 TYPE_NAME (rtype) = ada_type_name (type); 8637 TYPE_FIXED_INSTANCE (rtype) = 1; 8638 TYPE_LENGTH (rtype) = TYPE_LENGTH (type); 8639 8640 branch_type = to_fixed_variant_branch_type 8641 (TYPE_FIELD_TYPE (type, variant_field), 8642 cond_offset_host (valaddr, 8643 TYPE_FIELD_BITPOS (type, variant_field) 8644 / TARGET_CHAR_BIT), 8645 cond_offset_target (address, 8646 TYPE_FIELD_BITPOS (type, variant_field) 8647 / TARGET_CHAR_BIT), dval); 8648 if (branch_type == NULL) 8649 { 8650 int f; 8651 8652 for (f = variant_field + 1; f < nfields; f += 1) 8653 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f]; 8654 TYPE_NFIELDS (rtype) -= 1; 8655 } 8656 else 8657 { 8658 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type; 8659 TYPE_FIELD_NAME (rtype, variant_field) = "S"; 8660 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0; 8661 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type); 8662 } 8663 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field)); 8664 8665 value_free_to_mark (mark); 8666 return rtype; 8667} 8668 8669/* An ordinary record type (with fixed-length fields) that describes 8670 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at 8671 beginning of this section]. Any necessary discriminants' values 8672 should be in DVAL, a record value; it may be NULL if the object 8673 at ADDR itself contains any necessary discriminant values. 8674 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant 8675 values from the record are needed. Except in the case that DVAL, 8676 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless 8677 unchecked) is replaced by a particular branch of the variant. 8678 8679 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0 8680 is questionable and may be removed. It can arise during the 8681 processing of an unconstrained-array-of-record type where all the 8682 variant branches have exactly the same size. This is because in 8683 such cases, the compiler does not bother to use the XVS convention 8684 when encoding the record. I am currently dubious of this 8685 shortcut and suspect the compiler should be altered. FIXME. */ 8686 8687static struct type * 8688to_fixed_record_type (struct type *type0, const gdb_byte *valaddr, 8689 CORE_ADDR address, struct value *dval) 8690{ 8691 struct type *templ_type; 8692 8693 if (TYPE_FIXED_INSTANCE (type0)) 8694 return type0; 8695 8696 templ_type = dynamic_template_type (type0); 8697 8698 if (templ_type != NULL) 8699 return template_to_fixed_record_type (templ_type, valaddr, address, dval); 8700 else if (variant_field_index (type0) >= 0) 8701 { 8702 if (dval == NULL && valaddr == NULL && address == 0) 8703 return type0; 8704 return to_record_with_fixed_variant_part (type0, valaddr, address, 8705 dval); 8706 } 8707 else 8708 { 8709 TYPE_FIXED_INSTANCE (type0) = 1; 8710 return type0; 8711 } 8712 8713} 8714 8715/* An ordinary record type (with fixed-length fields) that describes 8716 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a 8717 union type. Any necessary discriminants' values should be in DVAL, 8718 a record value. That is, this routine selects the appropriate 8719 branch of the union at ADDR according to the discriminant value 8720 indicated in the union's type name. Returns VAR_TYPE0 itself if 8721 it represents a variant subject to a pragma Unchecked_Union. */ 8722 8723static struct type * 8724to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr, 8725 CORE_ADDR address, struct value *dval) 8726{ 8727 int which; 8728 struct type *templ_type; 8729 struct type *var_type; 8730 8731 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR) 8732 var_type = TYPE_TARGET_TYPE (var_type0); 8733 else 8734 var_type = var_type0; 8735 8736 templ_type = ada_find_parallel_type (var_type, "___XVU"); 8737 8738 if (templ_type != NULL) 8739 var_type = templ_type; 8740 8741 if (is_unchecked_variant (var_type, value_type (dval))) 8742 return var_type0; 8743 which = 8744 ada_which_variant_applies (var_type, 8745 value_type (dval), value_contents (dval)); 8746 8747 if (which < 0) 8748 return empty_record (var_type); 8749 else if (is_dynamic_field (var_type, which)) 8750 return to_fixed_record_type 8751 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)), 8752 valaddr, address, dval); 8753 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0) 8754 return 8755 to_fixed_record_type 8756 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval); 8757 else 8758 return TYPE_FIELD_TYPE (var_type, which); 8759} 8760 8761/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if 8762 ENCODING_TYPE, a type following the GNAT conventions for discrete 8763 type encodings, only carries redundant information. */ 8764 8765static int 8766ada_is_redundant_range_encoding (struct type *range_type, 8767 struct type *encoding_type) 8768{ 8769 const char *bounds_str; 8770 int n; 8771 LONGEST lo, hi; 8772 8773 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE); 8774 8775 if (TYPE_CODE (get_base_type (range_type)) 8776 != TYPE_CODE (get_base_type (encoding_type))) 8777 { 8778 /* The compiler probably used a simple base type to describe 8779 the range type instead of the range's actual base type, 8780 expecting us to get the real base type from the encoding 8781 anyway. In this situation, the encoding cannot be ignored 8782 as redundant. */ 8783 return 0; 8784 } 8785 8786 if (is_dynamic_type (range_type)) 8787 return 0; 8788 8789 if (TYPE_NAME (encoding_type) == NULL) 8790 return 0; 8791 8792 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_"); 8793 if (bounds_str == NULL) 8794 return 0; 8795 8796 n = 8; /* Skip "___XDLU_". */ 8797 if (!ada_scan_number (bounds_str, n, &lo, &n)) 8798 return 0; 8799 if (TYPE_LOW_BOUND (range_type) != lo) 8800 return 0; 8801 8802 n += 2; /* Skip the "__" separator between the two bounds. */ 8803 if (!ada_scan_number (bounds_str, n, &hi, &n)) 8804 return 0; 8805 if (TYPE_HIGH_BOUND (range_type) != hi) 8806 return 0; 8807 8808 return 1; 8809} 8810 8811/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE, 8812 a type following the GNAT encoding for describing array type 8813 indices, only carries redundant information. */ 8814 8815static int 8816ada_is_redundant_index_type_desc (struct type *array_type, 8817 struct type *desc_type) 8818{ 8819 struct type *this_layer = check_typedef (array_type); 8820 int i; 8821 8822 for (i = 0; i < TYPE_NFIELDS (desc_type); i++) 8823 { 8824 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer), 8825 TYPE_FIELD_TYPE (desc_type, i))) 8826 return 0; 8827 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer)); 8828 } 8829 8830 return 1; 8831} 8832 8833/* Assuming that TYPE0 is an array type describing the type of a value 8834 at ADDR, and that DVAL describes a record containing any 8835 discriminants used in TYPE0, returns a type for the value that 8836 contains no dynamic components (that is, no components whose sizes 8837 are determined by run-time quantities). Unless IGNORE_TOO_BIG is 8838 true, gives an error message if the resulting type's size is over 8839 varsize_limit. */ 8840 8841static struct type * 8842to_fixed_array_type (struct type *type0, struct value *dval, 8843 int ignore_too_big) 8844{ 8845 struct type *index_type_desc; 8846 struct type *result; 8847 int constrained_packed_array_p; 8848 static const char *xa_suffix = "___XA"; 8849 8850 type0 = ada_check_typedef (type0); 8851 if (TYPE_FIXED_INSTANCE (type0)) 8852 return type0; 8853 8854 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0); 8855 if (constrained_packed_array_p) 8856 type0 = decode_constrained_packed_array_type (type0); 8857 8858 index_type_desc = ada_find_parallel_type (type0, xa_suffix); 8859 8860 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an 8861 encoding suffixed with 'P' may still be generated. If so, 8862 it should be used to find the XA type. */ 8863 8864 if (index_type_desc == NULL) 8865 { 8866 const char *type_name = ada_type_name (type0); 8867 8868 if (type_name != NULL) 8869 { 8870 const int len = strlen (type_name); 8871 char *name = (char *) alloca (len + strlen (xa_suffix)); 8872 8873 if (type_name[len - 1] == 'P') 8874 { 8875 strcpy (name, type_name); 8876 strcpy (name + len - 1, xa_suffix); 8877 index_type_desc = ada_find_parallel_type_with_name (type0, name); 8878 } 8879 } 8880 } 8881 8882 ada_fixup_array_indexes_type (index_type_desc); 8883 if (index_type_desc != NULL 8884 && ada_is_redundant_index_type_desc (type0, index_type_desc)) 8885 { 8886 /* Ignore this ___XA parallel type, as it does not bring any 8887 useful information. This allows us to avoid creating fixed 8888 versions of the array's index types, which would be identical 8889 to the original ones. This, in turn, can also help avoid 8890 the creation of fixed versions of the array itself. */ 8891 index_type_desc = NULL; 8892 } 8893 8894 if (index_type_desc == NULL) 8895 { 8896 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0)); 8897 8898 /* NOTE: elt_type---the fixed version of elt_type0---should never 8899 depend on the contents of the array in properly constructed 8900 debugging data. */ 8901 /* Create a fixed version of the array element type. 8902 We're not providing the address of an element here, 8903 and thus the actual object value cannot be inspected to do 8904 the conversion. This should not be a problem, since arrays of 8905 unconstrained objects are not allowed. In particular, all 8906 the elements of an array of a tagged type should all be of 8907 the same type specified in the debugging info. No need to 8908 consult the object tag. */ 8909 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1); 8910 8911 /* Make sure we always create a new array type when dealing with 8912 packed array types, since we're going to fix-up the array 8913 type length and element bitsize a little further down. */ 8914 if (elt_type0 == elt_type && !constrained_packed_array_p) 8915 result = type0; 8916 else 8917 result = create_array_type (alloc_type_copy (type0), 8918 elt_type, TYPE_INDEX_TYPE (type0)); 8919 } 8920 else 8921 { 8922 int i; 8923 struct type *elt_type0; 8924 8925 elt_type0 = type0; 8926 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1) 8927 elt_type0 = TYPE_TARGET_TYPE (elt_type0); 8928 8929 /* NOTE: result---the fixed version of elt_type0---should never 8930 depend on the contents of the array in properly constructed 8931 debugging data. */ 8932 /* Create a fixed version of the array element type. 8933 We're not providing the address of an element here, 8934 and thus the actual object value cannot be inspected to do 8935 the conversion. This should not be a problem, since arrays of 8936 unconstrained objects are not allowed. In particular, all 8937 the elements of an array of a tagged type should all be of 8938 the same type specified in the debugging info. No need to 8939 consult the object tag. */ 8940 result = 8941 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1); 8942 8943 elt_type0 = type0; 8944 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1) 8945 { 8946 struct type *range_type = 8947 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval); 8948 8949 result = create_array_type (alloc_type_copy (elt_type0), 8950 result, range_type); 8951 elt_type0 = TYPE_TARGET_TYPE (elt_type0); 8952 } 8953 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit) 8954 error (_("array type with dynamic size is larger than varsize-limit")); 8955 } 8956 8957 /* We want to preserve the type name. This can be useful when 8958 trying to get the type name of a value that has already been 8959 printed (for instance, if the user did "print VAR; whatis $". */ 8960 TYPE_NAME (result) = TYPE_NAME (type0); 8961 8962 if (constrained_packed_array_p) 8963 { 8964 /* So far, the resulting type has been created as if the original 8965 type was a regular (non-packed) array type. As a result, the 8966 bitsize of the array elements needs to be set again, and the array 8967 length needs to be recomputed based on that bitsize. */ 8968 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result)); 8969 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0); 8970 8971 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0); 8972 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT; 8973 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize) 8974 TYPE_LENGTH (result)++; 8975 } 8976 8977 TYPE_FIXED_INSTANCE (result) = 1; 8978 return result; 8979} 8980 8981 8982/* A standard type (containing no dynamically sized components) 8983 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS) 8984 DVAL describes a record containing any discriminants used in TYPE0, 8985 and may be NULL if there are none, or if the object of type TYPE at 8986 ADDRESS or in VALADDR contains these discriminants. 8987 8988 If CHECK_TAG is not null, in the case of tagged types, this function 8989 attempts to locate the object's tag and use it to compute the actual 8990 type. However, when ADDRESS is null, we cannot use it to determine the 8991 location of the tag, and therefore compute the tagged type's actual type. 8992 So we return the tagged type without consulting the tag. */ 8993 8994static struct type * 8995ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr, 8996 CORE_ADDR address, struct value *dval, int check_tag) 8997{ 8998 type = ada_check_typedef (type); 8999 switch (TYPE_CODE (type)) 9000 { 9001 default: 9002 return type; 9003 case TYPE_CODE_STRUCT: 9004 { 9005 struct type *static_type = to_static_fixed_type (type); 9006 struct type *fixed_record_type = 9007 to_fixed_record_type (type, valaddr, address, NULL); 9008 9009 /* If STATIC_TYPE is a tagged type and we know the object's address, 9010 then we can determine its tag, and compute the object's actual 9011 type from there. Note that we have to use the fixed record 9012 type (the parent part of the record may have dynamic fields 9013 and the way the location of _tag is expressed may depend on 9014 them). */ 9015 9016 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0)) 9017 { 9018 struct value *tag = 9019 value_tag_from_contents_and_address 9020 (fixed_record_type, 9021 valaddr, 9022 address); 9023 struct type *real_type = type_from_tag (tag); 9024 struct value *obj = 9025 value_from_contents_and_address (fixed_record_type, 9026 valaddr, 9027 address); 9028 fixed_record_type = value_type (obj); 9029 if (real_type != NULL) 9030 return to_fixed_record_type 9031 (real_type, NULL, 9032 value_address (ada_tag_value_at_base_address (obj)), NULL); 9033 } 9034 9035 /* Check to see if there is a parallel ___XVZ variable. 9036 If there is, then it provides the actual size of our type. */ 9037 else if (ada_type_name (fixed_record_type) != NULL) 9038 { 9039 const char *name = ada_type_name (fixed_record_type); 9040 char *xvz_name 9041 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */); 9042 bool xvz_found = false; 9043 LONGEST size; 9044 9045 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name); 9046 TRY 9047 { 9048 xvz_found = get_int_var_value (xvz_name, size); 9049 } 9050 CATCH (except, RETURN_MASK_ERROR) 9051 { 9052 /* We found the variable, but somehow failed to read 9053 its value. Rethrow the same error, but with a little 9054 bit more information, to help the user understand 9055 what went wrong (Eg: the variable might have been 9056 optimized out). */ 9057 throw_error (except.error, 9058 _("unable to read value of %s (%s)"), 9059 xvz_name, except.message); 9060 } 9061 END_CATCH 9062 9063 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size) 9064 { 9065 fixed_record_type = copy_type (fixed_record_type); 9066 TYPE_LENGTH (fixed_record_type) = size; 9067 9068 /* The FIXED_RECORD_TYPE may have be a stub. We have 9069 observed this when the debugging info is STABS, and 9070 apparently it is something that is hard to fix. 9071 9072 In practice, we don't need the actual type definition 9073 at all, because the presence of the XVZ variable allows us 9074 to assume that there must be a XVS type as well, which we 9075 should be able to use later, when we need the actual type 9076 definition. 9077 9078 In the meantime, pretend that the "fixed" type we are 9079 returning is NOT a stub, because this can cause trouble 9080 when using this type to create new types targeting it. 9081 Indeed, the associated creation routines often check 9082 whether the target type is a stub and will try to replace 9083 it, thus using a type with the wrong size. This, in turn, 9084 might cause the new type to have the wrong size too. 9085 Consider the case of an array, for instance, where the size 9086 of the array is computed from the number of elements in 9087 our array multiplied by the size of its element. */ 9088 TYPE_STUB (fixed_record_type) = 0; 9089 } 9090 } 9091 return fixed_record_type; 9092 } 9093 case TYPE_CODE_ARRAY: 9094 return to_fixed_array_type (type, dval, 1); 9095 case TYPE_CODE_UNION: 9096 if (dval == NULL) 9097 return type; 9098 else 9099 return to_fixed_variant_branch_type (type, valaddr, address, dval); 9100 } 9101} 9102 9103/* The same as ada_to_fixed_type_1, except that it preserves the type 9104 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed. 9105 9106 The typedef layer needs be preserved in order to differentiate between 9107 arrays and array pointers when both types are implemented using the same 9108 fat pointer. In the array pointer case, the pointer is encoded as 9109 a typedef of the pointer type. For instance, considering: 9110 9111 type String_Access is access String; 9112 S1 : String_Access := null; 9113 9114 To the debugger, S1 is defined as a typedef of type String. But 9115 to the user, it is a pointer. So if the user tries to print S1, 9116 we should not dereference the array, but print the array address 9117 instead. 9118 9119 If we didn't preserve the typedef layer, we would lose the fact that 9120 the type is to be presented as a pointer (needs de-reference before 9121 being printed). And we would also use the source-level type name. */ 9122 9123struct type * 9124ada_to_fixed_type (struct type *type, const gdb_byte *valaddr, 9125 CORE_ADDR address, struct value *dval, int check_tag) 9126 9127{ 9128 struct type *fixed_type = 9129 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag); 9130 9131 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE, 9132 then preserve the typedef layer. 9133 9134 Implementation note: We can only check the main-type portion of 9135 the TYPE and FIXED_TYPE, because eliminating the typedef layer 9136 from TYPE now returns a type that has the same instance flags 9137 as TYPE. For instance, if TYPE is a "typedef const", and its 9138 target type is a "struct", then the typedef elimination will return 9139 a "const" version of the target type. See check_typedef for more 9140 details about how the typedef layer elimination is done. 9141 9142 brobecker/2010-11-19: It seems to me that the only case where it is 9143 useful to preserve the typedef layer is when dealing with fat pointers. 9144 Perhaps, we could add a check for that and preserve the typedef layer 9145 only in that situation. But this seems unecessary so far, probably 9146 because we call check_typedef/ada_check_typedef pretty much everywhere. 9147 */ 9148 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF 9149 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type)) 9150 == TYPE_MAIN_TYPE (fixed_type))) 9151 return type; 9152 9153 return fixed_type; 9154} 9155 9156/* A standard (static-sized) type corresponding as well as possible to 9157 TYPE0, but based on no runtime data. */ 9158 9159static struct type * 9160to_static_fixed_type (struct type *type0) 9161{ 9162 struct type *type; 9163 9164 if (type0 == NULL) 9165 return NULL; 9166 9167 if (TYPE_FIXED_INSTANCE (type0)) 9168 return type0; 9169 9170 type0 = ada_check_typedef (type0); 9171 9172 switch (TYPE_CODE (type0)) 9173 { 9174 default: 9175 return type0; 9176 case TYPE_CODE_STRUCT: 9177 type = dynamic_template_type (type0); 9178 if (type != NULL) 9179 return template_to_static_fixed_type (type); 9180 else 9181 return template_to_static_fixed_type (type0); 9182 case TYPE_CODE_UNION: 9183 type = ada_find_parallel_type (type0, "___XVU"); 9184 if (type != NULL) 9185 return template_to_static_fixed_type (type); 9186 else 9187 return template_to_static_fixed_type (type0); 9188 } 9189} 9190 9191/* A static approximation of TYPE with all type wrappers removed. */ 9192 9193static struct type * 9194static_unwrap_type (struct type *type) 9195{ 9196 if (ada_is_aligner_type (type)) 9197 { 9198 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0); 9199 if (ada_type_name (type1) == NULL) 9200 TYPE_NAME (type1) = ada_type_name (type); 9201 9202 return static_unwrap_type (type1); 9203 } 9204 else 9205 { 9206 struct type *raw_real_type = ada_get_base_type (type); 9207 9208 if (raw_real_type == type) 9209 return type; 9210 else 9211 return to_static_fixed_type (raw_real_type); 9212 } 9213} 9214 9215/* In some cases, incomplete and private types require 9216 cross-references that are not resolved as records (for example, 9217 type Foo; 9218 type FooP is access Foo; 9219 V: FooP; 9220 type Foo is array ...; 9221 ). In these cases, since there is no mechanism for producing 9222 cross-references to such types, we instead substitute for FooP a 9223 stub enumeration type that is nowhere resolved, and whose tag is 9224 the name of the actual type. Call these types "non-record stubs". */ 9225 9226/* A type equivalent to TYPE that is not a non-record stub, if one 9227 exists, otherwise TYPE. */ 9228 9229struct type * 9230ada_check_typedef (struct type *type) 9231{ 9232 if (type == NULL) 9233 return NULL; 9234 9235 /* If our type is an access to an unconstrained array, which is encoded 9236 as a TYPE_CODE_TYPEDEF of a fat pointer, then we're done. 9237 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is 9238 what allows us to distinguish between fat pointers that represent 9239 array types, and fat pointers that represent array access types 9240 (in both cases, the compiler implements them as fat pointers). */ 9241 if (ada_is_access_to_unconstrained_array (type)) 9242 return type; 9243 9244 type = check_typedef (type); 9245 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM 9246 || !TYPE_STUB (type) 9247 || TYPE_NAME (type) == NULL) 9248 return type; 9249 else 9250 { 9251 const char *name = TYPE_NAME (type); 9252 struct type *type1 = ada_find_any_type (name); 9253 9254 if (type1 == NULL) 9255 return type; 9256 9257 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with 9258 stubs pointing to arrays, as we don't create symbols for array 9259 types, only for the typedef-to-array types). If that's the case, 9260 strip the typedef layer. */ 9261 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF) 9262 type1 = ada_check_typedef (type1); 9263 9264 return type1; 9265 } 9266} 9267 9268/* A value representing the data at VALADDR/ADDRESS as described by 9269 type TYPE0, but with a standard (static-sized) type that correctly 9270 describes it. If VAL0 is not NULL and TYPE0 already is a standard 9271 type, then return VAL0 [this feature is simply to avoid redundant 9272 creation of struct values]. */ 9273 9274static struct value * 9275ada_to_fixed_value_create (struct type *type0, CORE_ADDR address, 9276 struct value *val0) 9277{ 9278 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1); 9279 9280 if (type == type0 && val0 != NULL) 9281 return val0; 9282 9283 if (VALUE_LVAL (val0) != lval_memory) 9284 { 9285 /* Our value does not live in memory; it could be a convenience 9286 variable, for instance. Create a not_lval value using val0's 9287 contents. */ 9288 return value_from_contents (type, value_contents (val0)); 9289 } 9290 9291 return value_from_contents_and_address (type, 0, address); 9292} 9293 9294/* A value representing VAL, but with a standard (static-sized) type 9295 that correctly describes it. Does not necessarily create a new 9296 value. */ 9297 9298struct value * 9299ada_to_fixed_value (struct value *val) 9300{ 9301 val = unwrap_value (val); 9302 val = ada_to_fixed_value_create (value_type (val), value_address (val), val); 9303 return val; 9304} 9305 9306 9307/* Attributes */ 9308 9309/* Table mapping attribute numbers to names. 9310 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */ 9311 9312static const char *attribute_names[] = { 9313 "<?>", 9314 9315 "first", 9316 "last", 9317 "length", 9318 "image", 9319 "max", 9320 "min", 9321 "modulus", 9322 "pos", 9323 "size", 9324 "tag", 9325 "val", 9326 0 9327}; 9328 9329const char * 9330ada_attribute_name (enum exp_opcode n) 9331{ 9332 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL) 9333 return attribute_names[n - OP_ATR_FIRST + 1]; 9334 else 9335 return attribute_names[0]; 9336} 9337 9338/* Evaluate the 'POS attribute applied to ARG. */ 9339 9340static LONGEST 9341pos_atr (struct value *arg) 9342{ 9343 struct value *val = coerce_ref (arg); 9344 struct type *type = value_type (val); 9345 LONGEST result; 9346 9347 if (!discrete_type_p (type)) 9348 error (_("'POS only defined on discrete types")); 9349 9350 if (!discrete_position (type, value_as_long (val), &result)) 9351 error (_("enumeration value is invalid: can't find 'POS")); 9352 9353 return result; 9354} 9355 9356static struct value * 9357value_pos_atr (struct type *type, struct value *arg) 9358{ 9359 return value_from_longest (type, pos_atr (arg)); 9360} 9361 9362/* Evaluate the TYPE'VAL attribute applied to ARG. */ 9363 9364static struct value * 9365value_val_atr (struct type *type, struct value *arg) 9366{ 9367 if (!discrete_type_p (type)) 9368 error (_("'VAL only defined on discrete types")); 9369 if (!integer_type_p (value_type (arg))) 9370 error (_("'VAL requires integral argument")); 9371 9372 if (TYPE_CODE (type) == TYPE_CODE_ENUM) 9373 { 9374 long pos = value_as_long (arg); 9375 9376 if (pos < 0 || pos >= TYPE_NFIELDS (type)) 9377 error (_("argument to 'VAL out of range")); 9378 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos)); 9379 } 9380 else 9381 return value_from_longest (type, value_as_long (arg)); 9382} 9383 9384 9385 /* Evaluation */ 9386 9387/* True if TYPE appears to be an Ada character type. 9388 [At the moment, this is true only for Character and Wide_Character; 9389 It is a heuristic test that could stand improvement]. */ 9390 9391int 9392ada_is_character_type (struct type *type) 9393{ 9394 const char *name; 9395 9396 /* If the type code says it's a character, then assume it really is, 9397 and don't check any further. */ 9398 if (TYPE_CODE (type) == TYPE_CODE_CHAR) 9399 return 1; 9400 9401 /* Otherwise, assume it's a character type iff it is a discrete type 9402 with a known character type name. */ 9403 name = ada_type_name (type); 9404 return (name != NULL 9405 && (TYPE_CODE (type) == TYPE_CODE_INT 9406 || TYPE_CODE (type) == TYPE_CODE_RANGE) 9407 && (strcmp (name, "character") == 0 9408 || strcmp (name, "wide_character") == 0 9409 || strcmp (name, "wide_wide_character") == 0 9410 || strcmp (name, "unsigned char") == 0)); 9411} 9412 9413/* True if TYPE appears to be an Ada string type. */ 9414 9415int 9416ada_is_string_type (struct type *type) 9417{ 9418 type = ada_check_typedef (type); 9419 if (type != NULL 9420 && TYPE_CODE (type) != TYPE_CODE_PTR 9421 && (ada_is_simple_array_type (type) 9422 || ada_is_array_descriptor_type (type)) 9423 && ada_array_arity (type) == 1) 9424 { 9425 struct type *elttype = ada_array_element_type (type, 1); 9426 9427 return ada_is_character_type (elttype); 9428 } 9429 else 9430 return 0; 9431} 9432 9433/* The compiler sometimes provides a parallel XVS type for a given 9434 PAD type. Normally, it is safe to follow the PAD type directly, 9435 but older versions of the compiler have a bug that causes the offset 9436 of its "F" field to be wrong. Following that field in that case 9437 would lead to incorrect results, but this can be worked around 9438 by ignoring the PAD type and using the associated XVS type instead. 9439 9440 Set to True if the debugger should trust the contents of PAD types. 9441 Otherwise, ignore the PAD type if there is a parallel XVS type. */ 9442static int trust_pad_over_xvs = 1; 9443 9444/* True if TYPE is a struct type introduced by the compiler to force the 9445 alignment of a value. Such types have a single field with a 9446 distinctive name. */ 9447 9448int 9449ada_is_aligner_type (struct type *type) 9450{ 9451 type = ada_check_typedef (type); 9452 9453 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL) 9454 return 0; 9455 9456 return (TYPE_CODE (type) == TYPE_CODE_STRUCT 9457 && TYPE_NFIELDS (type) == 1 9458 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0); 9459} 9460 9461/* If there is an ___XVS-convention type parallel to SUBTYPE, return 9462 the parallel type. */ 9463 9464struct type * 9465ada_get_base_type (struct type *raw_type) 9466{ 9467 struct type *real_type_namer; 9468 struct type *raw_real_type; 9469 9470 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT) 9471 return raw_type; 9472 9473 if (ada_is_aligner_type (raw_type)) 9474 /* The encoding specifies that we should always use the aligner type. 9475 So, even if this aligner type has an associated XVS type, we should 9476 simply ignore it. 9477 9478 According to the compiler gurus, an XVS type parallel to an aligner 9479 type may exist because of a stabs limitation. In stabs, aligner 9480 types are empty because the field has a variable-sized type, and 9481 thus cannot actually be used as an aligner type. As a result, 9482 we need the associated parallel XVS type to decode the type. 9483 Since the policy in the compiler is to not change the internal 9484 representation based on the debugging info format, we sometimes 9485 end up having a redundant XVS type parallel to the aligner type. */ 9486 return raw_type; 9487 9488 real_type_namer = ada_find_parallel_type (raw_type, "___XVS"); 9489 if (real_type_namer == NULL 9490 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT 9491 || TYPE_NFIELDS (real_type_namer) != 1) 9492 return raw_type; 9493 9494 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF) 9495 { 9496 /* This is an older encoding form where the base type needs to be 9497 looked up by name. We prefer the newer enconding because it is 9498 more efficient. */ 9499 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0)); 9500 if (raw_real_type == NULL) 9501 return raw_type; 9502 else 9503 return raw_real_type; 9504 } 9505 9506 /* The field in our XVS type is a reference to the base type. */ 9507 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0)); 9508} 9509 9510/* The type of value designated by TYPE, with all aligners removed. */ 9511 9512struct type * 9513ada_aligned_type (struct type *type) 9514{ 9515 if (ada_is_aligner_type (type)) 9516 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0)); 9517 else 9518 return ada_get_base_type (type); 9519} 9520 9521 9522/* The address of the aligned value in an object at address VALADDR 9523 having type TYPE. Assumes ada_is_aligner_type (TYPE). */ 9524 9525const gdb_byte * 9526ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr) 9527{ 9528 if (ada_is_aligner_type (type)) 9529 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0), 9530 valaddr + 9531 TYPE_FIELD_BITPOS (type, 9532 0) / TARGET_CHAR_BIT); 9533 else 9534 return valaddr; 9535} 9536 9537 9538 9539/* The printed representation of an enumeration literal with encoded 9540 name NAME. The value is good to the next call of ada_enum_name. */ 9541const char * 9542ada_enum_name (const char *name) 9543{ 9544 static char *result; 9545 static size_t result_len = 0; 9546 const char *tmp; 9547 9548 /* First, unqualify the enumeration name: 9549 1. Search for the last '.' character. If we find one, then skip 9550 all the preceding characters, the unqualified name starts 9551 right after that dot. 9552 2. Otherwise, we may be debugging on a target where the compiler 9553 translates dots into "__". Search forward for double underscores, 9554 but stop searching when we hit an overloading suffix, which is 9555 of the form "__" followed by digits. */ 9556 9557 tmp = strrchr (name, '.'); 9558 if (tmp != NULL) 9559 name = tmp + 1; 9560 else 9561 { 9562 while ((tmp = strstr (name, "__")) != NULL) 9563 { 9564 if (isdigit (tmp[2])) 9565 break; 9566 else 9567 name = tmp + 2; 9568 } 9569 } 9570 9571 if (name[0] == 'Q') 9572 { 9573 int v; 9574 9575 if (name[1] == 'U' || name[1] == 'W') 9576 { 9577 if (sscanf (name + 2, "%x", &v) != 1) 9578 return name; 9579 } 9580 else 9581 return name; 9582 9583 GROW_VECT (result, result_len, 16); 9584 if (isascii (v) && isprint (v)) 9585 xsnprintf (result, result_len, "'%c'", v); 9586 else if (name[1] == 'U') 9587 xsnprintf (result, result_len, "[\"%02x\"]", v); 9588 else 9589 xsnprintf (result, result_len, "[\"%04x\"]", v); 9590 9591 return result; 9592 } 9593 else 9594 { 9595 tmp = strstr (name, "__"); 9596 if (tmp == NULL) 9597 tmp = strstr (name, "$"); 9598 if (tmp != NULL) 9599 { 9600 GROW_VECT (result, result_len, tmp - name + 1); 9601 strncpy (result, name, tmp - name); 9602 result[tmp - name] = '\0'; 9603 return result; 9604 } 9605 9606 return name; 9607 } 9608} 9609 9610/* Evaluate the subexpression of EXP starting at *POS as for 9611 evaluate_type, updating *POS to point just past the evaluated 9612 expression. */ 9613 9614static struct value * 9615evaluate_subexp_type (struct expression *exp, int *pos) 9616{ 9617 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS); 9618} 9619 9620/* If VAL is wrapped in an aligner or subtype wrapper, return the 9621 value it wraps. */ 9622 9623static struct value * 9624unwrap_value (struct value *val) 9625{ 9626 struct type *type = ada_check_typedef (value_type (val)); 9627 9628 if (ada_is_aligner_type (type)) 9629 { 9630 struct value *v = ada_value_struct_elt (val, "F", 0); 9631 struct type *val_type = ada_check_typedef (value_type (v)); 9632 9633 if (ada_type_name (val_type) == NULL) 9634 TYPE_NAME (val_type) = ada_type_name (type); 9635 9636 return unwrap_value (v); 9637 } 9638 else 9639 { 9640 struct type *raw_real_type = 9641 ada_check_typedef (ada_get_base_type (type)); 9642 9643 /* If there is no parallel XVS or XVE type, then the value is 9644 already unwrapped. Return it without further modification. */ 9645 if ((type == raw_real_type) 9646 && ada_find_parallel_type (type, "___XVE") == NULL) 9647 return val; 9648 9649 return 9650 coerce_unspec_val_to_type 9651 (val, ada_to_fixed_type (raw_real_type, 0, 9652 value_address (val), 9653 NULL, 1)); 9654 } 9655} 9656 9657static struct value * 9658cast_from_fixed (struct type *type, struct value *arg) 9659{ 9660 struct value *scale = ada_scaling_factor (value_type (arg)); 9661 arg = value_cast (value_type (scale), arg); 9662 9663 arg = value_binop (arg, scale, BINOP_MUL); 9664 return value_cast (type, arg); 9665} 9666 9667static struct value * 9668cast_to_fixed (struct type *type, struct value *arg) 9669{ 9670 if (type == value_type (arg)) 9671 return arg; 9672 9673 struct value *scale = ada_scaling_factor (type); 9674 if (ada_is_fixed_point_type (value_type (arg))) 9675 arg = cast_from_fixed (value_type (scale), arg); 9676 else 9677 arg = value_cast (value_type (scale), arg); 9678 9679 arg = value_binop (arg, scale, BINOP_DIV); 9680 return value_cast (type, arg); 9681} 9682 9683/* Given two array types T1 and T2, return nonzero iff both arrays 9684 contain the same number of elements. */ 9685 9686static int 9687ada_same_array_size_p (struct type *t1, struct type *t2) 9688{ 9689 LONGEST lo1, hi1, lo2, hi2; 9690 9691 /* Get the array bounds in order to verify that the size of 9692 the two arrays match. */ 9693 if (!get_array_bounds (t1, &lo1, &hi1) 9694 || !get_array_bounds (t2, &lo2, &hi2)) 9695 error (_("unable to determine array bounds")); 9696 9697 /* To make things easier for size comparison, normalize a bit 9698 the case of empty arrays by making sure that the difference 9699 between upper bound and lower bound is always -1. */ 9700 if (lo1 > hi1) 9701 hi1 = lo1 - 1; 9702 if (lo2 > hi2) 9703 hi2 = lo2 - 1; 9704 9705 return (hi1 - lo1 == hi2 - lo2); 9706} 9707 9708/* Assuming that VAL is an array of integrals, and TYPE represents 9709 an array with the same number of elements, but with wider integral 9710 elements, return an array "casted" to TYPE. In practice, this 9711 means that the returned array is built by casting each element 9712 of the original array into TYPE's (wider) element type. */ 9713 9714static struct value * 9715ada_promote_array_of_integrals (struct type *type, struct value *val) 9716{ 9717 struct type *elt_type = TYPE_TARGET_TYPE (type); 9718 LONGEST lo, hi; 9719 struct value *res; 9720 LONGEST i; 9721 9722 /* Verify that both val and type are arrays of scalars, and 9723 that the size of val's elements is smaller than the size 9724 of type's element. */ 9725 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY); 9726 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type))); 9727 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY); 9728 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val)))); 9729 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type)) 9730 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val)))); 9731 9732 if (!get_array_bounds (type, &lo, &hi)) 9733 error (_("unable to determine array bounds")); 9734 9735 res = allocate_value (type); 9736 9737 /* Promote each array element. */ 9738 for (i = 0; i < hi - lo + 1; i++) 9739 { 9740 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i)); 9741 9742 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)), 9743 value_contents_all (elt), TYPE_LENGTH (elt_type)); 9744 } 9745 9746 return res; 9747} 9748 9749/* Coerce VAL as necessary for assignment to an lval of type TYPE, and 9750 return the converted value. */ 9751 9752static struct value * 9753coerce_for_assign (struct type *type, struct value *val) 9754{ 9755 struct type *type2 = value_type (val); 9756 9757 if (type == type2) 9758 return val; 9759 9760 type2 = ada_check_typedef (type2); 9761 type = ada_check_typedef (type); 9762 9763 if (TYPE_CODE (type2) == TYPE_CODE_PTR 9764 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 9765 { 9766 val = ada_value_ind (val); 9767 type2 = value_type (val); 9768 } 9769 9770 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY 9771 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 9772 { 9773 if (!ada_same_array_size_p (type, type2)) 9774 error (_("cannot assign arrays of different length")); 9775 9776 if (is_integral_type (TYPE_TARGET_TYPE (type)) 9777 && is_integral_type (TYPE_TARGET_TYPE (type2)) 9778 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2)) 9779 < TYPE_LENGTH (TYPE_TARGET_TYPE (type))) 9780 { 9781 /* Allow implicit promotion of the array elements to 9782 a wider type. */ 9783 return ada_promote_array_of_integrals (type, val); 9784 } 9785 9786 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2)) 9787 != TYPE_LENGTH (TYPE_TARGET_TYPE (type))) 9788 error (_("Incompatible types in assignment")); 9789 deprecated_set_value_type (val, type); 9790 } 9791 return val; 9792} 9793 9794static struct value * 9795ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op) 9796{ 9797 struct value *val; 9798 struct type *type1, *type2; 9799 LONGEST v, v1, v2; 9800 9801 arg1 = coerce_ref (arg1); 9802 arg2 = coerce_ref (arg2); 9803 type1 = get_base_type (ada_check_typedef (value_type (arg1))); 9804 type2 = get_base_type (ada_check_typedef (value_type (arg2))); 9805 9806 if (TYPE_CODE (type1) != TYPE_CODE_INT 9807 || TYPE_CODE (type2) != TYPE_CODE_INT) 9808 return value_binop (arg1, arg2, op); 9809 9810 switch (op) 9811 { 9812 case BINOP_MOD: 9813 case BINOP_DIV: 9814 case BINOP_REM: 9815 break; 9816 default: 9817 return value_binop (arg1, arg2, op); 9818 } 9819 9820 v2 = value_as_long (arg2); 9821 if (v2 == 0) 9822 error (_("second operand of %s must not be zero."), op_string (op)); 9823 9824 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD) 9825 return value_binop (arg1, arg2, op); 9826 9827 v1 = value_as_long (arg1); 9828 switch (op) 9829 { 9830 case BINOP_DIV: 9831 v = v1 / v2; 9832 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0) 9833 v += v > 0 ? -1 : 1; 9834 break; 9835 case BINOP_REM: 9836 v = v1 % v2; 9837 if (v * v1 < 0) 9838 v -= v2; 9839 break; 9840 default: 9841 /* Should not reach this point. */ 9842 v = 0; 9843 } 9844 9845 val = allocate_value (type1); 9846 store_unsigned_integer (value_contents_raw (val), 9847 TYPE_LENGTH (value_type (val)), 9848 gdbarch_byte_order (get_type_arch (type1)), v); 9849 return val; 9850} 9851 9852static int 9853ada_value_equal (struct value *arg1, struct value *arg2) 9854{ 9855 if (ada_is_direct_array_type (value_type (arg1)) 9856 || ada_is_direct_array_type (value_type (arg2))) 9857 { 9858 struct type *arg1_type, *arg2_type; 9859 9860 /* Automatically dereference any array reference before 9861 we attempt to perform the comparison. */ 9862 arg1 = ada_coerce_ref (arg1); 9863 arg2 = ada_coerce_ref (arg2); 9864 9865 arg1 = ada_coerce_to_simple_array (arg1); 9866 arg2 = ada_coerce_to_simple_array (arg2); 9867 9868 arg1_type = ada_check_typedef (value_type (arg1)); 9869 arg2_type = ada_check_typedef (value_type (arg2)); 9870 9871 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY 9872 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY) 9873 error (_("Attempt to compare array with non-array")); 9874 /* FIXME: The following works only for types whose 9875 representations use all bits (no padding or undefined bits) 9876 and do not have user-defined equality. */ 9877 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type) 9878 && memcmp (value_contents (arg1), value_contents (arg2), 9879 TYPE_LENGTH (arg1_type)) == 0); 9880 } 9881 return value_equal (arg1, arg2); 9882} 9883 9884/* Total number of component associations in the aggregate starting at 9885 index PC in EXP. Assumes that index PC is the start of an 9886 OP_AGGREGATE. */ 9887 9888static int 9889num_component_specs (struct expression *exp, int pc) 9890{ 9891 int n, m, i; 9892 9893 m = exp->elts[pc + 1].longconst; 9894 pc += 3; 9895 n = 0; 9896 for (i = 0; i < m; i += 1) 9897 { 9898 switch (exp->elts[pc].opcode) 9899 { 9900 default: 9901 n += 1; 9902 break; 9903 case OP_CHOICES: 9904 n += exp->elts[pc + 1].longconst; 9905 break; 9906 } 9907 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP); 9908 } 9909 return n; 9910} 9911 9912/* Assign the result of evaluating EXP starting at *POS to the INDEXth 9913 component of LHS (a simple array or a record), updating *POS past 9914 the expression, assuming that LHS is contained in CONTAINER. Does 9915 not modify the inferior's memory, nor does it modify LHS (unless 9916 LHS == CONTAINER). */ 9917 9918static void 9919assign_component (struct value *container, struct value *lhs, LONGEST index, 9920 struct expression *exp, int *pos) 9921{ 9922 struct value *mark = value_mark (); 9923 struct value *elt; 9924 struct type *lhs_type = check_typedef (value_type (lhs)); 9925 9926 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY) 9927 { 9928 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int; 9929 struct value *index_val = value_from_longest (index_type, index); 9930 9931 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val)); 9932 } 9933 else 9934 { 9935 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs)); 9936 elt = ada_to_fixed_value (elt); 9937 } 9938 9939 if (exp->elts[*pos].opcode == OP_AGGREGATE) 9940 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL); 9941 else 9942 value_assign_to_component (container, elt, 9943 ada_evaluate_subexp (NULL, exp, pos, 9944 EVAL_NORMAL)); 9945 9946 value_free_to_mark (mark); 9947} 9948 9949/* Assuming that LHS represents an lvalue having a record or array 9950 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment 9951 of that aggregate's value to LHS, advancing *POS past the 9952 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an 9953 lvalue containing LHS (possibly LHS itself). Does not modify 9954 the inferior's memory, nor does it modify the contents of 9955 LHS (unless == CONTAINER). Returns the modified CONTAINER. */ 9956 9957static struct value * 9958assign_aggregate (struct value *container, 9959 struct value *lhs, struct expression *exp, 9960 int *pos, enum noside noside) 9961{ 9962 struct type *lhs_type; 9963 int n = exp->elts[*pos+1].longconst; 9964 LONGEST low_index, high_index; 9965 int num_specs; 9966 LONGEST *indices; 9967 int max_indices, num_indices; 9968 int i; 9969 9970 *pos += 3; 9971 if (noside != EVAL_NORMAL) 9972 { 9973 for (i = 0; i < n; i += 1) 9974 ada_evaluate_subexp (NULL, exp, pos, noside); 9975 return container; 9976 } 9977 9978 container = ada_coerce_ref (container); 9979 if (ada_is_direct_array_type (value_type (container))) 9980 container = ada_coerce_to_simple_array (container); 9981 lhs = ada_coerce_ref (lhs); 9982 if (!deprecated_value_modifiable (lhs)) 9983 error (_("Left operand of assignment is not a modifiable lvalue.")); 9984 9985 lhs_type = check_typedef (value_type (lhs)); 9986 if (ada_is_direct_array_type (lhs_type)) 9987 { 9988 lhs = ada_coerce_to_simple_array (lhs); 9989 lhs_type = check_typedef (value_type (lhs)); 9990 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type); 9991 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type); 9992 } 9993 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT) 9994 { 9995 low_index = 0; 9996 high_index = num_visible_fields (lhs_type) - 1; 9997 } 9998 else 9999 error (_("Left-hand side must be array or record.")); 10000 10001 num_specs = num_component_specs (exp, *pos - 3); 10002 max_indices = 4 * num_specs + 4; 10003 indices = XALLOCAVEC (LONGEST, max_indices); 10004 indices[0] = indices[1] = low_index - 1; 10005 indices[2] = indices[3] = high_index + 1; 10006 num_indices = 4; 10007 10008 for (i = 0; i < n; i += 1) 10009 { 10010 switch (exp->elts[*pos].opcode) 10011 { 10012 case OP_CHOICES: 10013 aggregate_assign_from_choices (container, lhs, exp, pos, indices, 10014 &num_indices, max_indices, 10015 low_index, high_index); 10016 break; 10017 case OP_POSITIONAL: 10018 aggregate_assign_positional (container, lhs, exp, pos, indices, 10019 &num_indices, max_indices, 10020 low_index, high_index); 10021 break; 10022 case OP_OTHERS: 10023 if (i != n-1) 10024 error (_("Misplaced 'others' clause")); 10025 aggregate_assign_others (container, lhs, exp, pos, indices, 10026 num_indices, low_index, high_index); 10027 break; 10028 default: 10029 error (_("Internal error: bad aggregate clause")); 10030 } 10031 } 10032 10033 return container; 10034} 10035 10036/* Assign into the component of LHS indexed by the OP_POSITIONAL 10037 construct at *POS, updating *POS past the construct, given that 10038 the positions are relative to lower bound LOW, where HIGH is the 10039 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1] 10040 updating *NUM_INDICES as needed. CONTAINER is as for 10041 assign_aggregate. */ 10042static void 10043aggregate_assign_positional (struct value *container, 10044 struct value *lhs, struct expression *exp, 10045 int *pos, LONGEST *indices, int *num_indices, 10046 int max_indices, LONGEST low, LONGEST high) 10047{ 10048 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low; 10049 10050 if (ind - 1 == high) 10051 warning (_("Extra components in aggregate ignored.")); 10052 if (ind <= high) 10053 { 10054 add_component_interval (ind, ind, indices, num_indices, max_indices); 10055 *pos += 3; 10056 assign_component (container, lhs, ind, exp, pos); 10057 } 10058 else 10059 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 10060} 10061 10062/* Assign into the components of LHS indexed by the OP_CHOICES 10063 construct at *POS, updating *POS past the construct, given that 10064 the allowable indices are LOW..HIGH. Record the indices assigned 10065 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as 10066 needed. CONTAINER is as for assign_aggregate. */ 10067static void 10068aggregate_assign_from_choices (struct value *container, 10069 struct value *lhs, struct expression *exp, 10070 int *pos, LONGEST *indices, int *num_indices, 10071 int max_indices, LONGEST low, LONGEST high) 10072{ 10073 int j; 10074 int n_choices = longest_to_int (exp->elts[*pos+1].longconst); 10075 int choice_pos, expr_pc; 10076 int is_array = ada_is_direct_array_type (value_type (lhs)); 10077 10078 choice_pos = *pos += 3; 10079 10080 for (j = 0; j < n_choices; j += 1) 10081 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 10082 expr_pc = *pos; 10083 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 10084 10085 for (j = 0; j < n_choices; j += 1) 10086 { 10087 LONGEST lower, upper; 10088 enum exp_opcode op = exp->elts[choice_pos].opcode; 10089 10090 if (op == OP_DISCRETE_RANGE) 10091 { 10092 choice_pos += 1; 10093 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos, 10094 EVAL_NORMAL)); 10095 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos, 10096 EVAL_NORMAL)); 10097 } 10098 else if (is_array) 10099 { 10100 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos, 10101 EVAL_NORMAL)); 10102 upper = lower; 10103 } 10104 else 10105 { 10106 int ind; 10107 const char *name; 10108 10109 switch (op) 10110 { 10111 case OP_NAME: 10112 name = &exp->elts[choice_pos + 2].string; 10113 break; 10114 case OP_VAR_VALUE: 10115 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol); 10116 break; 10117 default: 10118 error (_("Invalid record component association.")); 10119 } 10120 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP); 10121 ind = 0; 10122 if (! find_struct_field (name, value_type (lhs), 0, 10123 NULL, NULL, NULL, NULL, &ind)) 10124 error (_("Unknown component name: %s."), name); 10125 lower = upper = ind; 10126 } 10127 10128 if (lower <= upper && (lower < low || upper > high)) 10129 error (_("Index in component association out of bounds.")); 10130 10131 add_component_interval (lower, upper, indices, num_indices, 10132 max_indices); 10133 while (lower <= upper) 10134 { 10135 int pos1; 10136 10137 pos1 = expr_pc; 10138 assign_component (container, lhs, lower, exp, &pos1); 10139 lower += 1; 10140 } 10141 } 10142} 10143 10144/* Assign the value of the expression in the OP_OTHERS construct in 10145 EXP at *POS into the components of LHS indexed from LOW .. HIGH that 10146 have not been previously assigned. The index intervals already assigned 10147 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the 10148 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */ 10149static void 10150aggregate_assign_others (struct value *container, 10151 struct value *lhs, struct expression *exp, 10152 int *pos, LONGEST *indices, int num_indices, 10153 LONGEST low, LONGEST high) 10154{ 10155 int i; 10156 int expr_pc = *pos + 1; 10157 10158 for (i = 0; i < num_indices - 2; i += 2) 10159 { 10160 LONGEST ind; 10161 10162 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1) 10163 { 10164 int localpos; 10165 10166 localpos = expr_pc; 10167 assign_component (container, lhs, ind, exp, &localpos); 10168 } 10169 } 10170 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 10171} 10172 10173/* Add the interval [LOW .. HIGH] to the sorted set of intervals 10174 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ], 10175 modifying *SIZE as needed. It is an error if *SIZE exceeds 10176 MAX_SIZE. The resulting intervals do not overlap. */ 10177static void 10178add_component_interval (LONGEST low, LONGEST high, 10179 LONGEST* indices, int *size, int max_size) 10180{ 10181 int i, j; 10182 10183 for (i = 0; i < *size; i += 2) { 10184 if (high >= indices[i] && low <= indices[i + 1]) 10185 { 10186 int kh; 10187 10188 for (kh = i + 2; kh < *size; kh += 2) 10189 if (high < indices[kh]) 10190 break; 10191 if (low < indices[i]) 10192 indices[i] = low; 10193 indices[i + 1] = indices[kh - 1]; 10194 if (high > indices[i + 1]) 10195 indices[i + 1] = high; 10196 memcpy (indices + i + 2, indices + kh, *size - kh); 10197 *size -= kh - i - 2; 10198 return; 10199 } 10200 else if (high < indices[i]) 10201 break; 10202 } 10203 10204 if (*size == max_size) 10205 error (_("Internal error: miscounted aggregate components.")); 10206 *size += 2; 10207 for (j = *size-1; j >= i+2; j -= 1) 10208 indices[j] = indices[j - 2]; 10209 indices[i] = low; 10210 indices[i + 1] = high; 10211} 10212 10213/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2 10214 is different. */ 10215 10216static struct value * 10217ada_value_cast (struct type *type, struct value *arg2) 10218{ 10219 if (type == ada_check_typedef (value_type (arg2))) 10220 return arg2; 10221 10222 if (ada_is_fixed_point_type (type)) 10223 return cast_to_fixed (type, arg2); 10224 10225 if (ada_is_fixed_point_type (value_type (arg2))) 10226 return cast_from_fixed (type, arg2); 10227 10228 return value_cast (type, arg2); 10229} 10230 10231/* Evaluating Ada expressions, and printing their result. 10232 ------------------------------------------------------ 10233 10234 1. Introduction: 10235 ---------------- 10236 10237 We usually evaluate an Ada expression in order to print its value. 10238 We also evaluate an expression in order to print its type, which 10239 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation, 10240 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the 10241 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of 10242 the evaluation compared to the EVAL_NORMAL, but is otherwise very 10243 similar. 10244 10245 Evaluating expressions is a little more complicated for Ada entities 10246 than it is for entities in languages such as C. The main reason for 10247 this is that Ada provides types whose definition might be dynamic. 10248 One example of such types is variant records. Or another example 10249 would be an array whose bounds can only be known at run time. 10250 10251 The following description is a general guide as to what should be 10252 done (and what should NOT be done) in order to evaluate an expression 10253 involving such types, and when. This does not cover how the semantic 10254 information is encoded by GNAT as this is covered separatly. For the 10255 document used as the reference for the GNAT encoding, see exp_dbug.ads 10256 in the GNAT sources. 10257 10258 Ideally, we should embed each part of this description next to its 10259 associated code. Unfortunately, the amount of code is so vast right 10260 now that it's hard to see whether the code handling a particular 10261 situation might be duplicated or not. One day, when the code is 10262 cleaned up, this guide might become redundant with the comments 10263 inserted in the code, and we might want to remove it. 10264 10265 2. ``Fixing'' an Entity, the Simple Case: 10266 ----------------------------------------- 10267 10268 When evaluating Ada expressions, the tricky issue is that they may 10269 reference entities whose type contents and size are not statically 10270 known. Consider for instance a variant record: 10271 10272 type Rec (Empty : Boolean := True) is record 10273 case Empty is 10274 when True => null; 10275 when False => Value : Integer; 10276 end case; 10277 end record; 10278 Yes : Rec := (Empty => False, Value => 1); 10279 No : Rec := (empty => True); 10280 10281 The size and contents of that record depends on the value of the 10282 descriminant (Rec.Empty). At this point, neither the debugging 10283 information nor the associated type structure in GDB are able to 10284 express such dynamic types. So what the debugger does is to create 10285 "fixed" versions of the type that applies to the specific object. 10286 We also informally refer to this opperation as "fixing" an object, 10287 which means creating its associated fixed type. 10288 10289 Example: when printing the value of variable "Yes" above, its fixed 10290 type would look like this: 10291 10292 type Rec is record 10293 Empty : Boolean; 10294 Value : Integer; 10295 end record; 10296 10297 On the other hand, if we printed the value of "No", its fixed type 10298 would become: 10299 10300 type Rec is record 10301 Empty : Boolean; 10302 end record; 10303 10304 Things become a little more complicated when trying to fix an entity 10305 with a dynamic type that directly contains another dynamic type, 10306 such as an array of variant records, for instance. There are 10307 two possible cases: Arrays, and records. 10308 10309 3. ``Fixing'' Arrays: 10310 --------------------- 10311 10312 The type structure in GDB describes an array in terms of its bounds, 10313 and the type of its elements. By design, all elements in the array 10314 have the same type and we cannot represent an array of variant elements 10315 using the current type structure in GDB. When fixing an array, 10316 we cannot fix the array element, as we would potentially need one 10317 fixed type per element of the array. As a result, the best we can do 10318 when fixing an array is to produce an array whose bounds and size 10319 are correct (allowing us to read it from memory), but without having 10320 touched its element type. Fixing each element will be done later, 10321 when (if) necessary. 10322 10323 Arrays are a little simpler to handle than records, because the same 10324 amount of memory is allocated for each element of the array, even if 10325 the amount of space actually used by each element differs from element 10326 to element. Consider for instance the following array of type Rec: 10327 10328 type Rec_Array is array (1 .. 2) of Rec; 10329 10330 The actual amount of memory occupied by each element might be different 10331 from element to element, depending on the value of their discriminant. 10332 But the amount of space reserved for each element in the array remains 10333 fixed regardless. So we simply need to compute that size using 10334 the debugging information available, from which we can then determine 10335 the array size (we multiply the number of elements of the array by 10336 the size of each element). 10337 10338 The simplest case is when we have an array of a constrained element 10339 type. For instance, consider the following type declarations: 10340 10341 type Bounded_String (Max_Size : Integer) is 10342 Length : Integer; 10343 Buffer : String (1 .. Max_Size); 10344 end record; 10345 type Bounded_String_Array is array (1 ..2) of Bounded_String (80); 10346 10347 In this case, the compiler describes the array as an array of 10348 variable-size elements (identified by its XVS suffix) for which 10349 the size can be read in the parallel XVZ variable. 10350 10351 In the case of an array of an unconstrained element type, the compiler 10352 wraps the array element inside a private PAD type. This type should not 10353 be shown to the user, and must be "unwrap"'ed before printing. Note 10354 that we also use the adjective "aligner" in our code to designate 10355 these wrapper types. 10356 10357 In some cases, the size allocated for each element is statically 10358 known. In that case, the PAD type already has the correct size, 10359 and the array element should remain unfixed. 10360 10361 But there are cases when this size is not statically known. 10362 For instance, assuming that "Five" is an integer variable: 10363 10364 type Dynamic is array (1 .. Five) of Integer; 10365 type Wrapper (Has_Length : Boolean := False) is record 10366 Data : Dynamic; 10367 case Has_Length is 10368 when True => Length : Integer; 10369 when False => null; 10370 end case; 10371 end record; 10372 type Wrapper_Array is array (1 .. 2) of Wrapper; 10373 10374 Hello : Wrapper_Array := (others => (Has_Length => True, 10375 Data => (others => 17), 10376 Length => 1)); 10377 10378 10379 The debugging info would describe variable Hello as being an 10380 array of a PAD type. The size of that PAD type is not statically 10381 known, but can be determined using a parallel XVZ variable. 10382 In that case, a copy of the PAD type with the correct size should 10383 be used for the fixed array. 10384 10385 3. ``Fixing'' record type objects: 10386 ---------------------------------- 10387 10388 Things are slightly different from arrays in the case of dynamic 10389 record types. In this case, in order to compute the associated 10390 fixed type, we need to determine the size and offset of each of 10391 its components. This, in turn, requires us to compute the fixed 10392 type of each of these components. 10393 10394 Consider for instance the example: 10395 10396 type Bounded_String (Max_Size : Natural) is record 10397 Str : String (1 .. Max_Size); 10398 Length : Natural; 10399 end record; 10400 My_String : Bounded_String (Max_Size => 10); 10401 10402 In that case, the position of field "Length" depends on the size 10403 of field Str, which itself depends on the value of the Max_Size 10404 discriminant. In order to fix the type of variable My_String, 10405 we need to fix the type of field Str. Therefore, fixing a variant 10406 record requires us to fix each of its components. 10407 10408 However, if a component does not have a dynamic size, the component 10409 should not be fixed. In particular, fields that use a PAD type 10410 should not fixed. Here is an example where this might happen 10411 (assuming type Rec above): 10412 10413 type Container (Big : Boolean) is record 10414 First : Rec; 10415 After : Integer; 10416 case Big is 10417 when True => Another : Integer; 10418 when False => null; 10419 end case; 10420 end record; 10421 My_Container : Container := (Big => False, 10422 First => (Empty => True), 10423 After => 42); 10424 10425 In that example, the compiler creates a PAD type for component First, 10426 whose size is constant, and then positions the component After just 10427 right after it. The offset of component After is therefore constant 10428 in this case. 10429 10430 The debugger computes the position of each field based on an algorithm 10431 that uses, among other things, the actual position and size of the field 10432 preceding it. Let's now imagine that the user is trying to print 10433 the value of My_Container. If the type fixing was recursive, we would 10434 end up computing the offset of field After based on the size of the 10435 fixed version of field First. And since in our example First has 10436 only one actual field, the size of the fixed type is actually smaller 10437 than the amount of space allocated to that field, and thus we would 10438 compute the wrong offset of field After. 10439 10440 To make things more complicated, we need to watch out for dynamic 10441 components of variant records (identified by the ___XVL suffix in 10442 the component name). Even if the target type is a PAD type, the size 10443 of that type might not be statically known. So the PAD type needs 10444 to be unwrapped and the resulting type needs to be fixed. Otherwise, 10445 we might end up with the wrong size for our component. This can be 10446 observed with the following type declarations: 10447 10448 type Octal is new Integer range 0 .. 7; 10449 type Octal_Array is array (Positive range <>) of Octal; 10450 pragma Pack (Octal_Array); 10451 10452 type Octal_Buffer (Size : Positive) is record 10453 Buffer : Octal_Array (1 .. Size); 10454 Length : Integer; 10455 end record; 10456 10457 In that case, Buffer is a PAD type whose size is unset and needs 10458 to be computed by fixing the unwrapped type. 10459 10460 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity: 10461 ---------------------------------------------------------- 10462 10463 Lastly, when should the sub-elements of an entity that remained unfixed 10464 thus far, be actually fixed? 10465 10466 The answer is: Only when referencing that element. For instance 10467 when selecting one component of a record, this specific component 10468 should be fixed at that point in time. Or when printing the value 10469 of a record, each component should be fixed before its value gets 10470 printed. Similarly for arrays, the element of the array should be 10471 fixed when printing each element of the array, or when extracting 10472 one element out of that array. On the other hand, fixing should 10473 not be performed on the elements when taking a slice of an array! 10474 10475 Note that one of the side effects of miscomputing the offset and 10476 size of each field is that we end up also miscomputing the size 10477 of the containing type. This can have adverse results when computing 10478 the value of an entity. GDB fetches the value of an entity based 10479 on the size of its type, and thus a wrong size causes GDB to fetch 10480 the wrong amount of memory. In the case where the computed size is 10481 too small, GDB fetches too little data to print the value of our 10482 entity. Results in this case are unpredictable, as we usually read 10483 past the buffer containing the data =:-o. */ 10484 10485/* Evaluate a subexpression of EXP, at index *POS, and return a value 10486 for that subexpression cast to TO_TYPE. Advance *POS over the 10487 subexpression. */ 10488 10489static value * 10490ada_evaluate_subexp_for_cast (expression *exp, int *pos, 10491 enum noside noside, struct type *to_type) 10492{ 10493 int pc = *pos; 10494 10495 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE 10496 || exp->elts[pc].opcode == OP_VAR_VALUE) 10497 { 10498 (*pos) += 4; 10499 10500 value *val; 10501 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE) 10502 { 10503 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10504 return value_zero (to_type, not_lval); 10505 10506 val = evaluate_var_msym_value (noside, 10507 exp->elts[pc + 1].objfile, 10508 exp->elts[pc + 2].msymbol); 10509 } 10510 else 10511 val = evaluate_var_value (noside, 10512 exp->elts[pc + 1].block, 10513 exp->elts[pc + 2].symbol); 10514 10515 if (noside == EVAL_SKIP) 10516 return eval_skip_value (exp); 10517 10518 val = ada_value_cast (to_type, val); 10519 10520 /* Follow the Ada language semantics that do not allow taking 10521 an address of the result of a cast (view conversion in Ada). */ 10522 if (VALUE_LVAL (val) == lval_memory) 10523 { 10524 if (value_lazy (val)) 10525 value_fetch_lazy (val); 10526 VALUE_LVAL (val) = not_lval; 10527 } 10528 return val; 10529 } 10530 10531 value *val = evaluate_subexp (to_type, exp, pos, noside); 10532 if (noside == EVAL_SKIP) 10533 return eval_skip_value (exp); 10534 return ada_value_cast (to_type, val); 10535} 10536 10537/* Implement the evaluate_exp routine in the exp_descriptor structure 10538 for the Ada language. */ 10539 10540static struct value * 10541ada_evaluate_subexp (struct type *expect_type, struct expression *exp, 10542 int *pos, enum noside noside) 10543{ 10544 enum exp_opcode op; 10545 int tem; 10546 int pc; 10547 int preeval_pos; 10548 struct value *arg1 = NULL, *arg2 = NULL, *arg3; 10549 struct type *type; 10550 int nargs, oplen; 10551 struct value **argvec; 10552 10553 pc = *pos; 10554 *pos += 1; 10555 op = exp->elts[pc].opcode; 10556 10557 switch (op) 10558 { 10559 default: 10560 *pos -= 1; 10561 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside); 10562 10563 if (noside == EVAL_NORMAL) 10564 arg1 = unwrap_value (arg1); 10565 10566 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided, 10567 then we need to perform the conversion manually, because 10568 evaluate_subexp_standard doesn't do it. This conversion is 10569 necessary in Ada because the different kinds of float/fixed 10570 types in Ada have different representations. 10571 10572 Similarly, we need to perform the conversion from OP_LONG 10573 ourselves. */ 10574 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL) 10575 arg1 = ada_value_cast (expect_type, arg1); 10576 10577 return arg1; 10578 10579 case OP_STRING: 10580 { 10581 struct value *result; 10582 10583 *pos -= 1; 10584 result = evaluate_subexp_standard (expect_type, exp, pos, noside); 10585 /* The result type will have code OP_STRING, bashed there from 10586 OP_ARRAY. Bash it back. */ 10587 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING) 10588 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY; 10589 return result; 10590 } 10591 10592 case UNOP_CAST: 10593 (*pos) += 2; 10594 type = exp->elts[pc + 1].type; 10595 return ada_evaluate_subexp_for_cast (exp, pos, noside, type); 10596 10597 case UNOP_QUAL: 10598 (*pos) += 2; 10599 type = exp->elts[pc + 1].type; 10600 return ada_evaluate_subexp (type, exp, pos, noside); 10601 10602 case BINOP_ASSIGN: 10603 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10604 if (exp->elts[*pos].opcode == OP_AGGREGATE) 10605 { 10606 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside); 10607 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS) 10608 return arg1; 10609 return ada_value_assign (arg1, arg1); 10610 } 10611 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1, 10612 except if the lhs of our assignment is a convenience variable. 10613 In the case of assigning to a convenience variable, the lhs 10614 should be exactly the result of the evaluation of the rhs. */ 10615 type = value_type (arg1); 10616 if (VALUE_LVAL (arg1) == lval_internalvar) 10617 type = NULL; 10618 arg2 = evaluate_subexp (type, exp, pos, noside); 10619 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS) 10620 return arg1; 10621 if (ada_is_fixed_point_type (value_type (arg1))) 10622 arg2 = cast_to_fixed (value_type (arg1), arg2); 10623 else if (ada_is_fixed_point_type (value_type (arg2))) 10624 error 10625 (_("Fixed-point values must be assigned to fixed-point variables")); 10626 else 10627 arg2 = coerce_for_assign (value_type (arg1), arg2); 10628 return ada_value_assign (arg1, arg2); 10629 10630 case BINOP_ADD: 10631 arg1 = evaluate_subexp_with_coercion (exp, pos, noside); 10632 arg2 = evaluate_subexp_with_coercion (exp, pos, noside); 10633 if (noside == EVAL_SKIP) 10634 goto nosideret; 10635 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR) 10636 return (value_from_longest 10637 (value_type (arg1), 10638 value_as_long (arg1) + value_as_long (arg2))); 10639 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR) 10640 return (value_from_longest 10641 (value_type (arg2), 10642 value_as_long (arg1) + value_as_long (arg2))); 10643 if ((ada_is_fixed_point_type (value_type (arg1)) 10644 || ada_is_fixed_point_type (value_type (arg2))) 10645 && value_type (arg1) != value_type (arg2)) 10646 error (_("Operands of fixed-point addition must have the same type")); 10647 /* Do the addition, and cast the result to the type of the first 10648 argument. We cannot cast the result to a reference type, so if 10649 ARG1 is a reference type, find its underlying type. */ 10650 type = value_type (arg1); 10651 while (TYPE_CODE (type) == TYPE_CODE_REF) 10652 type = TYPE_TARGET_TYPE (type); 10653 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10654 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD)); 10655 10656 case BINOP_SUB: 10657 arg1 = evaluate_subexp_with_coercion (exp, pos, noside); 10658 arg2 = evaluate_subexp_with_coercion (exp, pos, noside); 10659 if (noside == EVAL_SKIP) 10660 goto nosideret; 10661 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR) 10662 return (value_from_longest 10663 (value_type (arg1), 10664 value_as_long (arg1) - value_as_long (arg2))); 10665 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR) 10666 return (value_from_longest 10667 (value_type (arg2), 10668 value_as_long (arg1) - value_as_long (arg2))); 10669 if ((ada_is_fixed_point_type (value_type (arg1)) 10670 || ada_is_fixed_point_type (value_type (arg2))) 10671 && value_type (arg1) != value_type (arg2)) 10672 error (_("Operands of fixed-point subtraction " 10673 "must have the same type")); 10674 /* Do the substraction, and cast the result to the type of the first 10675 argument. We cannot cast the result to a reference type, so if 10676 ARG1 is a reference type, find its underlying type. */ 10677 type = value_type (arg1); 10678 while (TYPE_CODE (type) == TYPE_CODE_REF) 10679 type = TYPE_TARGET_TYPE (type); 10680 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10681 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB)); 10682 10683 case BINOP_MUL: 10684 case BINOP_DIV: 10685 case BINOP_REM: 10686 case BINOP_MOD: 10687 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10688 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10689 if (noside == EVAL_SKIP) 10690 goto nosideret; 10691 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 10692 { 10693 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10694 return value_zero (value_type (arg1), not_lval); 10695 } 10696 else 10697 { 10698 type = builtin_type (exp->gdbarch)->builtin_double; 10699 if (ada_is_fixed_point_type (value_type (arg1))) 10700 arg1 = cast_from_fixed (type, arg1); 10701 if (ada_is_fixed_point_type (value_type (arg2))) 10702 arg2 = cast_from_fixed (type, arg2); 10703 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10704 return ada_value_binop (arg1, arg2, op); 10705 } 10706 10707 case BINOP_EQUAL: 10708 case BINOP_NOTEQUAL: 10709 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10710 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); 10711 if (noside == EVAL_SKIP) 10712 goto nosideret; 10713 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10714 tem = 0; 10715 else 10716 { 10717 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10718 tem = ada_value_equal (arg1, arg2); 10719 } 10720 if (op == BINOP_NOTEQUAL) 10721 tem = !tem; 10722 type = language_bool_type (exp->language_defn, exp->gdbarch); 10723 return value_from_longest (type, (LONGEST) tem); 10724 10725 case UNOP_NEG: 10726 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10727 if (noside == EVAL_SKIP) 10728 goto nosideret; 10729 else if (ada_is_fixed_point_type (value_type (arg1))) 10730 return value_cast (value_type (arg1), value_neg (arg1)); 10731 else 10732 { 10733 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 10734 return value_neg (arg1); 10735 } 10736 10737 case BINOP_LOGICAL_AND: 10738 case BINOP_LOGICAL_OR: 10739 case UNOP_LOGICAL_NOT: 10740 { 10741 struct value *val; 10742 10743 *pos -= 1; 10744 val = evaluate_subexp_standard (expect_type, exp, pos, noside); 10745 type = language_bool_type (exp->language_defn, exp->gdbarch); 10746 return value_cast (type, val); 10747 } 10748 10749 case BINOP_BITWISE_AND: 10750 case BINOP_BITWISE_IOR: 10751 case BINOP_BITWISE_XOR: 10752 { 10753 struct value *val; 10754 10755 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS); 10756 *pos = pc; 10757 val = evaluate_subexp_standard (expect_type, exp, pos, noside); 10758 10759 return value_cast (value_type (arg1), val); 10760 } 10761 10762 case OP_VAR_VALUE: 10763 *pos -= 1; 10764 10765 if (noside == EVAL_SKIP) 10766 { 10767 *pos += 4; 10768 goto nosideret; 10769 } 10770 10771 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN) 10772 /* Only encountered when an unresolved symbol occurs in a 10773 context other than a function call, in which case, it is 10774 invalid. */ 10775 error (_("Unexpected unresolved symbol, %s, during evaluation"), 10776 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 10777 10778 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10779 { 10780 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol)); 10781 /* Check to see if this is a tagged type. We also need to handle 10782 the case where the type is a reference to a tagged type, but 10783 we have to be careful to exclude pointers to tagged types. 10784 The latter should be shown as usual (as a pointer), whereas 10785 a reference should mostly be transparent to the user. */ 10786 if (ada_is_tagged_type (type, 0) 10787 || (TYPE_CODE (type) == TYPE_CODE_REF 10788 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))) 10789 { 10790 /* Tagged types are a little special in the fact that the real 10791 type is dynamic and can only be determined by inspecting the 10792 object's tag. This means that we need to get the object's 10793 value first (EVAL_NORMAL) and then extract the actual object 10794 type from its tag. 10795 10796 Note that we cannot skip the final step where we extract 10797 the object type from its tag, because the EVAL_NORMAL phase 10798 results in dynamic components being resolved into fixed ones. 10799 This can cause problems when trying to print the type 10800 description of tagged types whose parent has a dynamic size: 10801 We use the type name of the "_parent" component in order 10802 to print the name of the ancestor type in the type description. 10803 If that component had a dynamic size, the resolution into 10804 a fixed type would result in the loss of that type name, 10805 thus preventing us from printing the name of the ancestor 10806 type in the type description. */ 10807 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL); 10808 10809 if (TYPE_CODE (type) != TYPE_CODE_REF) 10810 { 10811 struct type *actual_type; 10812 10813 actual_type = type_from_tag (ada_value_tag (arg1)); 10814 if (actual_type == NULL) 10815 /* If, for some reason, we were unable to determine 10816 the actual type from the tag, then use the static 10817 approximation that we just computed as a fallback. 10818 This can happen if the debugging information is 10819 incomplete, for instance. */ 10820 actual_type = type; 10821 return value_zero (actual_type, not_lval); 10822 } 10823 else 10824 { 10825 /* In the case of a ref, ada_coerce_ref takes care 10826 of determining the actual type. But the evaluation 10827 should return a ref as it should be valid to ask 10828 for its address; so rebuild a ref after coerce. */ 10829 arg1 = ada_coerce_ref (arg1); 10830 return value_ref (arg1, TYPE_CODE_REF); 10831 } 10832 } 10833 10834 /* Records and unions for which GNAT encodings have been 10835 generated need to be statically fixed as well. 10836 Otherwise, non-static fixing produces a type where 10837 all dynamic properties are removed, which prevents "ptype" 10838 from being able to completely describe the type. 10839 For instance, a case statement in a variant record would be 10840 replaced by the relevant components based on the actual 10841 value of the discriminants. */ 10842 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT 10843 && dynamic_template_type (type) != NULL) 10844 || (TYPE_CODE (type) == TYPE_CODE_UNION 10845 && ada_find_parallel_type (type, "___XVU") != NULL)) 10846 { 10847 *pos += 4; 10848 return value_zero (to_static_fixed_type (type), not_lval); 10849 } 10850 } 10851 10852 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside); 10853 return ada_to_fixed_value (arg1); 10854 10855 case OP_FUNCALL: 10856 (*pos) += 2; 10857 10858 /* Allocate arg vector, including space for the function to be 10859 called in argvec[0] and a terminating NULL. */ 10860 nargs = longest_to_int (exp->elts[pc + 1].longconst); 10861 argvec = XALLOCAVEC (struct value *, nargs + 2); 10862 10863 if (exp->elts[*pos].opcode == OP_VAR_VALUE 10864 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 10865 error (_("Unexpected unresolved symbol, %s, during evaluation"), 10866 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol)); 10867 else 10868 { 10869 for (tem = 0; tem <= nargs; tem += 1) 10870 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10871 argvec[tem] = 0; 10872 10873 if (noside == EVAL_SKIP) 10874 goto nosideret; 10875 } 10876 10877 if (ada_is_constrained_packed_array_type 10878 (desc_base_type (value_type (argvec[0])))) 10879 argvec[0] = ada_coerce_to_simple_array (argvec[0]); 10880 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY 10881 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0) 10882 /* This is a packed array that has already been fixed, and 10883 therefore already coerced to a simple array. Nothing further 10884 to do. */ 10885 ; 10886 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF) 10887 { 10888 /* Make sure we dereference references so that all the code below 10889 feels like it's really handling the referenced value. Wrapping 10890 types (for alignment) may be there, so make sure we strip them as 10891 well. */ 10892 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0])); 10893 } 10894 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY 10895 && VALUE_LVAL (argvec[0]) == lval_memory) 10896 argvec[0] = value_addr (argvec[0]); 10897 10898 type = ada_check_typedef (value_type (argvec[0])); 10899 10900 /* Ada allows us to implicitly dereference arrays when subscripting 10901 them. So, if this is an array typedef (encoding use for array 10902 access types encoded as fat pointers), strip it now. */ 10903 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 10904 type = ada_typedef_target_type (type); 10905 10906 if (TYPE_CODE (type) == TYPE_CODE_PTR) 10907 { 10908 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))) 10909 { 10910 case TYPE_CODE_FUNC: 10911 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 10912 break; 10913 case TYPE_CODE_ARRAY: 10914 break; 10915 case TYPE_CODE_STRUCT: 10916 if (noside != EVAL_AVOID_SIDE_EFFECTS) 10917 argvec[0] = ada_value_ind (argvec[0]); 10918 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 10919 break; 10920 default: 10921 error (_("cannot subscript or call something of type `%s'"), 10922 ada_type_name (value_type (argvec[0]))); 10923 break; 10924 } 10925 } 10926 10927 switch (TYPE_CODE (type)) 10928 { 10929 case TYPE_CODE_FUNC: 10930 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10931 { 10932 if (TYPE_TARGET_TYPE (type) == NULL) 10933 error_call_unknown_return_type (NULL); 10934 return allocate_value (TYPE_TARGET_TYPE (type)); 10935 } 10936 return call_function_by_hand (argvec[0], NULL, 10937 gdb::make_array_view (argvec + 1, 10938 nargs)); 10939 case TYPE_CODE_INTERNAL_FUNCTION: 10940 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10941 /* We don't know anything about what the internal 10942 function might return, but we have to return 10943 something. */ 10944 return value_zero (builtin_type (exp->gdbarch)->builtin_int, 10945 not_lval); 10946 else 10947 return call_internal_function (exp->gdbarch, exp->language_defn, 10948 argvec[0], nargs, argvec + 1); 10949 10950 case TYPE_CODE_STRUCT: 10951 { 10952 int arity; 10953 10954 arity = ada_array_arity (type); 10955 type = ada_array_element_type (type, nargs); 10956 if (type == NULL) 10957 error (_("cannot subscript or call a record")); 10958 if (arity != nargs) 10959 error (_("wrong number of subscripts; expecting %d"), arity); 10960 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10961 return value_zero (ada_aligned_type (type), lval_memory); 10962 return 10963 unwrap_value (ada_value_subscript 10964 (argvec[0], nargs, argvec + 1)); 10965 } 10966 case TYPE_CODE_ARRAY: 10967 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10968 { 10969 type = ada_array_element_type (type, nargs); 10970 if (type == NULL) 10971 error (_("element type of array unknown")); 10972 else 10973 return value_zero (ada_aligned_type (type), lval_memory); 10974 } 10975 return 10976 unwrap_value (ada_value_subscript 10977 (ada_coerce_to_simple_array (argvec[0]), 10978 nargs, argvec + 1)); 10979 case TYPE_CODE_PTR: /* Pointer to array */ 10980 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10981 { 10982 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1); 10983 type = ada_array_element_type (type, nargs); 10984 if (type == NULL) 10985 error (_("element type of array unknown")); 10986 else 10987 return value_zero (ada_aligned_type (type), lval_memory); 10988 } 10989 return 10990 unwrap_value (ada_value_ptr_subscript (argvec[0], 10991 nargs, argvec + 1)); 10992 10993 default: 10994 error (_("Attempt to index or call something other than an " 10995 "array or function")); 10996 } 10997 10998 case TERNOP_SLICE: 10999 { 11000 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11001 struct value *low_bound_val = 11002 evaluate_subexp (NULL_TYPE, exp, pos, noside); 11003 struct value *high_bound_val = 11004 evaluate_subexp (NULL_TYPE, exp, pos, noside); 11005 LONGEST low_bound; 11006 LONGEST high_bound; 11007 11008 low_bound_val = coerce_ref (low_bound_val); 11009 high_bound_val = coerce_ref (high_bound_val); 11010 low_bound = value_as_long (low_bound_val); 11011 high_bound = value_as_long (high_bound_val); 11012 11013 if (noside == EVAL_SKIP) 11014 goto nosideret; 11015 11016 /* If this is a reference to an aligner type, then remove all 11017 the aligners. */ 11018 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF 11019 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array)))) 11020 TYPE_TARGET_TYPE (value_type (array)) = 11021 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array))); 11022 11023 if (ada_is_constrained_packed_array_type (value_type (array))) 11024 error (_("cannot slice a packed array")); 11025 11026 /* If this is a reference to an array or an array lvalue, 11027 convert to a pointer. */ 11028 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF 11029 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY 11030 && VALUE_LVAL (array) == lval_memory)) 11031 array = value_addr (array); 11032 11033 if (noside == EVAL_AVOID_SIDE_EFFECTS 11034 && ada_is_array_descriptor_type (ada_check_typedef 11035 (value_type (array)))) 11036 return empty_array (ada_type_of_array (array, 0), low_bound); 11037 11038 array = ada_coerce_to_simple_array_ptr (array); 11039 11040 /* If we have more than one level of pointer indirection, 11041 dereference the value until we get only one level. */ 11042 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR 11043 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array))) 11044 == TYPE_CODE_PTR)) 11045 array = value_ind (array); 11046 11047 /* Make sure we really do have an array type before going further, 11048 to avoid a SEGV when trying to get the index type or the target 11049 type later down the road if the debug info generated by 11050 the compiler is incorrect or incomplete. */ 11051 if (!ada_is_simple_array_type (value_type (array))) 11052 error (_("cannot take slice of non-array")); 11053 11054 if (TYPE_CODE (ada_check_typedef (value_type (array))) 11055 == TYPE_CODE_PTR) 11056 { 11057 struct type *type0 = ada_check_typedef (value_type (array)); 11058 11059 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS) 11060 return empty_array (TYPE_TARGET_TYPE (type0), low_bound); 11061 else 11062 { 11063 struct type *arr_type0 = 11064 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1); 11065 11066 return ada_value_slice_from_ptr (array, arr_type0, 11067 longest_to_int (low_bound), 11068 longest_to_int (high_bound)); 11069 } 11070 } 11071 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11072 return array; 11073 else if (high_bound < low_bound) 11074 return empty_array (value_type (array), low_bound); 11075 else 11076 return ada_value_slice (array, longest_to_int (low_bound), 11077 longest_to_int (high_bound)); 11078 } 11079 11080 case UNOP_IN_RANGE: 11081 (*pos) += 2; 11082 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11083 type = check_typedef (exp->elts[pc + 1].type); 11084 11085 if (noside == EVAL_SKIP) 11086 goto nosideret; 11087 11088 switch (TYPE_CODE (type)) 11089 { 11090 default: 11091 lim_warning (_("Membership test incompletely implemented; " 11092 "always returns true")); 11093 type = language_bool_type (exp->language_defn, exp->gdbarch); 11094 return value_from_longest (type, (LONGEST) 1); 11095 11096 case TYPE_CODE_RANGE: 11097 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type)); 11098 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type)); 11099 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 11100 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 11101 type = language_bool_type (exp->language_defn, exp->gdbarch); 11102 return 11103 value_from_longest (type, 11104 (value_less (arg1, arg3) 11105 || value_equal (arg1, arg3)) 11106 && (value_less (arg2, arg1) 11107 || value_equal (arg2, arg1))); 11108 } 11109 11110 case BINOP_IN_BOUNDS: 11111 (*pos) += 2; 11112 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11113 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11114 11115 if (noside == EVAL_SKIP) 11116 goto nosideret; 11117 11118 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11119 { 11120 type = language_bool_type (exp->language_defn, exp->gdbarch); 11121 return value_zero (type, not_lval); 11122 } 11123 11124 tem = longest_to_int (exp->elts[pc + 1].longconst); 11125 11126 type = ada_index_type (value_type (arg2), tem, "range"); 11127 if (!type) 11128 type = value_type (arg1); 11129 11130 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1)); 11131 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0)); 11132 11133 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 11134 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 11135 type = language_bool_type (exp->language_defn, exp->gdbarch); 11136 return 11137 value_from_longest (type, 11138 (value_less (arg1, arg3) 11139 || value_equal (arg1, arg3)) 11140 && (value_less (arg2, arg1) 11141 || value_equal (arg2, arg1))); 11142 11143 case TERNOP_IN_RANGE: 11144 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11145 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11146 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11147 11148 if (noside == EVAL_SKIP) 11149 goto nosideret; 11150 11151 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 11152 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 11153 type = language_bool_type (exp->language_defn, exp->gdbarch); 11154 return 11155 value_from_longest (type, 11156 (value_less (arg1, arg3) 11157 || value_equal (arg1, arg3)) 11158 && (value_less (arg2, arg1) 11159 || value_equal (arg2, arg1))); 11160 11161 case OP_ATR_FIRST: 11162 case OP_ATR_LAST: 11163 case OP_ATR_LENGTH: 11164 { 11165 struct type *type_arg; 11166 11167 if (exp->elts[*pos].opcode == OP_TYPE) 11168 { 11169 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 11170 arg1 = NULL; 11171 type_arg = check_typedef (exp->elts[pc + 2].type); 11172 } 11173 else 11174 { 11175 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11176 type_arg = NULL; 11177 } 11178 11179 if (exp->elts[*pos].opcode != OP_LONG) 11180 error (_("Invalid operand to '%s"), ada_attribute_name (op)); 11181 tem = longest_to_int (exp->elts[*pos + 2].longconst); 11182 *pos += 4; 11183 11184 if (noside == EVAL_SKIP) 11185 goto nosideret; 11186 11187 if (type_arg == NULL) 11188 { 11189 arg1 = ada_coerce_ref (arg1); 11190 11191 if (ada_is_constrained_packed_array_type (value_type (arg1))) 11192 arg1 = ada_coerce_to_simple_array (arg1); 11193 11194 if (op == OP_ATR_LENGTH) 11195 type = builtin_type (exp->gdbarch)->builtin_int; 11196 else 11197 { 11198 type = ada_index_type (value_type (arg1), tem, 11199 ada_attribute_name (op)); 11200 if (type == NULL) 11201 type = builtin_type (exp->gdbarch)->builtin_int; 11202 } 11203 11204 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11205 return allocate_value (type); 11206 11207 switch (op) 11208 { 11209 default: /* Should never happen. */ 11210 error (_("unexpected attribute encountered")); 11211 case OP_ATR_FIRST: 11212 return value_from_longest 11213 (type, ada_array_bound (arg1, tem, 0)); 11214 case OP_ATR_LAST: 11215 return value_from_longest 11216 (type, ada_array_bound (arg1, tem, 1)); 11217 case OP_ATR_LENGTH: 11218 return value_from_longest 11219 (type, ada_array_length (arg1, tem)); 11220 } 11221 } 11222 else if (discrete_type_p (type_arg)) 11223 { 11224 struct type *range_type; 11225 const char *name = ada_type_name (type_arg); 11226 11227 range_type = NULL; 11228 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM) 11229 range_type = to_fixed_range_type (type_arg, NULL); 11230 if (range_type == NULL) 11231 range_type = type_arg; 11232 switch (op) 11233 { 11234 default: 11235 error (_("unexpected attribute encountered")); 11236 case OP_ATR_FIRST: 11237 return value_from_longest 11238 (range_type, ada_discrete_type_low_bound (range_type)); 11239 case OP_ATR_LAST: 11240 return value_from_longest 11241 (range_type, ada_discrete_type_high_bound (range_type)); 11242 case OP_ATR_LENGTH: 11243 error (_("the 'length attribute applies only to array types")); 11244 } 11245 } 11246 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT) 11247 error (_("unimplemented type attribute")); 11248 else 11249 { 11250 LONGEST low, high; 11251 11252 if (ada_is_constrained_packed_array_type (type_arg)) 11253 type_arg = decode_constrained_packed_array_type (type_arg); 11254 11255 if (op == OP_ATR_LENGTH) 11256 type = builtin_type (exp->gdbarch)->builtin_int; 11257 else 11258 { 11259 type = ada_index_type (type_arg, tem, ada_attribute_name (op)); 11260 if (type == NULL) 11261 type = builtin_type (exp->gdbarch)->builtin_int; 11262 } 11263 11264 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11265 return allocate_value (type); 11266 11267 switch (op) 11268 { 11269 default: 11270 error (_("unexpected attribute encountered")); 11271 case OP_ATR_FIRST: 11272 low = ada_array_bound_from_type (type_arg, tem, 0); 11273 return value_from_longest (type, low); 11274 case OP_ATR_LAST: 11275 high = ada_array_bound_from_type (type_arg, tem, 1); 11276 return value_from_longest (type, high); 11277 case OP_ATR_LENGTH: 11278 low = ada_array_bound_from_type (type_arg, tem, 0); 11279 high = ada_array_bound_from_type (type_arg, tem, 1); 11280 return value_from_longest (type, high - low + 1); 11281 } 11282 } 11283 } 11284 11285 case OP_ATR_TAG: 11286 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11287 if (noside == EVAL_SKIP) 11288 goto nosideret; 11289 11290 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11291 return value_zero (ada_tag_type (arg1), not_lval); 11292 11293 return ada_value_tag (arg1); 11294 11295 case OP_ATR_MIN: 11296 case OP_ATR_MAX: 11297 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 11298 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11299 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11300 if (noside == EVAL_SKIP) 11301 goto nosideret; 11302 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11303 return value_zero (value_type (arg1), not_lval); 11304 else 11305 { 11306 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 11307 return value_binop (arg1, arg2, 11308 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX); 11309 } 11310 11311 case OP_ATR_MODULUS: 11312 { 11313 struct type *type_arg = check_typedef (exp->elts[pc + 2].type); 11314 11315 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 11316 if (noside == EVAL_SKIP) 11317 goto nosideret; 11318 11319 if (!ada_is_modular_type (type_arg)) 11320 error (_("'modulus must be applied to modular type")); 11321 11322 return value_from_longest (TYPE_TARGET_TYPE (type_arg), 11323 ada_modulus (type_arg)); 11324 } 11325 11326 11327 case OP_ATR_POS: 11328 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 11329 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11330 if (noside == EVAL_SKIP) 11331 goto nosideret; 11332 type = builtin_type (exp->gdbarch)->builtin_int; 11333 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11334 return value_zero (type, not_lval); 11335 else 11336 return value_pos_atr (type, arg1); 11337 11338 case OP_ATR_SIZE: 11339 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11340 type = value_type (arg1); 11341 11342 /* If the argument is a reference, then dereference its type, since 11343 the user is really asking for the size of the actual object, 11344 not the size of the pointer. */ 11345 if (TYPE_CODE (type) == TYPE_CODE_REF) 11346 type = TYPE_TARGET_TYPE (type); 11347 11348 if (noside == EVAL_SKIP) 11349 goto nosideret; 11350 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11351 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval); 11352 else 11353 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 11354 TARGET_CHAR_BIT * TYPE_LENGTH (type)); 11355 11356 case OP_ATR_VAL: 11357 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 11358 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11359 type = exp->elts[pc + 2].type; 11360 if (noside == EVAL_SKIP) 11361 goto nosideret; 11362 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11363 return value_zero (type, not_lval); 11364 else 11365 return value_val_atr (type, arg1); 11366 11367 case BINOP_EXP: 11368 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11369 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11370 if (noside == EVAL_SKIP) 11371 goto nosideret; 11372 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11373 return value_zero (value_type (arg1), not_lval); 11374 else 11375 { 11376 /* For integer exponentiation operations, 11377 only promote the first argument. */ 11378 if (is_integral_type (value_type (arg2))) 11379 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 11380 else 11381 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 11382 11383 return value_binop (arg1, arg2, op); 11384 } 11385 11386 case UNOP_PLUS: 11387 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11388 if (noside == EVAL_SKIP) 11389 goto nosideret; 11390 else 11391 return arg1; 11392 11393 case UNOP_ABS: 11394 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11395 if (noside == EVAL_SKIP) 11396 goto nosideret; 11397 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 11398 if (value_less (arg1, value_zero (value_type (arg1), not_lval))) 11399 return value_neg (arg1); 11400 else 11401 return arg1; 11402 11403 case UNOP_IND: 11404 preeval_pos = *pos; 11405 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11406 if (noside == EVAL_SKIP) 11407 goto nosideret; 11408 type = ada_check_typedef (value_type (arg1)); 11409 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11410 { 11411 if (ada_is_array_descriptor_type (type)) 11412 /* GDB allows dereferencing GNAT array descriptors. */ 11413 { 11414 struct type *arrType = ada_type_of_array (arg1, 0); 11415 11416 if (arrType == NULL) 11417 error (_("Attempt to dereference null array pointer.")); 11418 return value_at_lazy (arrType, 0); 11419 } 11420 else if (TYPE_CODE (type) == TYPE_CODE_PTR 11421 || TYPE_CODE (type) == TYPE_CODE_REF 11422 /* In C you can dereference an array to get the 1st elt. */ 11423 || TYPE_CODE (type) == TYPE_CODE_ARRAY) 11424 { 11425 /* As mentioned in the OP_VAR_VALUE case, tagged types can 11426 only be determined by inspecting the object's tag. 11427 This means that we need to evaluate completely the 11428 expression in order to get its type. */ 11429 11430 if ((TYPE_CODE (type) == TYPE_CODE_REF 11431 || TYPE_CODE (type) == TYPE_CODE_PTR) 11432 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)) 11433 { 11434 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos, 11435 EVAL_NORMAL); 11436 type = value_type (ada_value_ind (arg1)); 11437 } 11438 else 11439 { 11440 type = to_static_fixed_type 11441 (ada_aligned_type 11442 (ada_check_typedef (TYPE_TARGET_TYPE (type)))); 11443 } 11444 ada_ensure_varsize_limit (type); 11445 return value_zero (type, lval_memory); 11446 } 11447 else if (TYPE_CODE (type) == TYPE_CODE_INT) 11448 { 11449 /* GDB allows dereferencing an int. */ 11450 if (expect_type == NULL) 11451 return value_zero (builtin_type (exp->gdbarch)->builtin_int, 11452 lval_memory); 11453 else 11454 { 11455 expect_type = 11456 to_static_fixed_type (ada_aligned_type (expect_type)); 11457 return value_zero (expect_type, lval_memory); 11458 } 11459 } 11460 else 11461 error (_("Attempt to take contents of a non-pointer value.")); 11462 } 11463 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */ 11464 type = ada_check_typedef (value_type (arg1)); 11465 11466 if (TYPE_CODE (type) == TYPE_CODE_INT) 11467 /* GDB allows dereferencing an int. If we were given 11468 the expect_type, then use that as the target type. 11469 Otherwise, assume that the target type is an int. */ 11470 { 11471 if (expect_type != NULL) 11472 return ada_value_ind (value_cast (lookup_pointer_type (expect_type), 11473 arg1)); 11474 else 11475 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int, 11476 (CORE_ADDR) value_as_address (arg1)); 11477 } 11478 11479 if (ada_is_array_descriptor_type (type)) 11480 /* GDB allows dereferencing GNAT array descriptors. */ 11481 return ada_coerce_to_simple_array (arg1); 11482 else 11483 return ada_value_ind (arg1); 11484 11485 case STRUCTOP_STRUCT: 11486 tem = longest_to_int (exp->elts[pc + 1].longconst); 11487 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1); 11488 preeval_pos = *pos; 11489 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11490 if (noside == EVAL_SKIP) 11491 goto nosideret; 11492 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11493 { 11494 struct type *type1 = value_type (arg1); 11495 11496 if (ada_is_tagged_type (type1, 1)) 11497 { 11498 type = ada_lookup_struct_elt_type (type1, 11499 &exp->elts[pc + 2].string, 11500 1, 1); 11501 11502 /* If the field is not found, check if it exists in the 11503 extension of this object's type. This means that we 11504 need to evaluate completely the expression. */ 11505 11506 if (type == NULL) 11507 { 11508 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos, 11509 EVAL_NORMAL); 11510 arg1 = ada_value_struct_elt (arg1, 11511 &exp->elts[pc + 2].string, 11512 0); 11513 arg1 = unwrap_value (arg1); 11514 type = value_type (ada_to_fixed_value (arg1)); 11515 } 11516 } 11517 else 11518 type = 11519 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1, 11520 0); 11521 11522 return value_zero (ada_aligned_type (type), lval_memory); 11523 } 11524 else 11525 { 11526 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0); 11527 arg1 = unwrap_value (arg1); 11528 return ada_to_fixed_value (arg1); 11529 } 11530 11531 case OP_TYPE: 11532 /* The value is not supposed to be used. This is here to make it 11533 easier to accommodate expressions that contain types. */ 11534 (*pos) += 2; 11535 if (noside == EVAL_SKIP) 11536 goto nosideret; 11537 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11538 return allocate_value (exp->elts[pc + 1].type); 11539 else 11540 error (_("Attempt to use a type name as an expression")); 11541 11542 case OP_AGGREGATE: 11543 case OP_CHOICES: 11544 case OP_OTHERS: 11545 case OP_DISCRETE_RANGE: 11546 case OP_POSITIONAL: 11547 case OP_NAME: 11548 if (noside == EVAL_NORMAL) 11549 switch (op) 11550 { 11551 case OP_NAME: 11552 error (_("Undefined name, ambiguous name, or renaming used in " 11553 "component association: %s."), &exp->elts[pc+2].string); 11554 case OP_AGGREGATE: 11555 error (_("Aggregates only allowed on the right of an assignment")); 11556 default: 11557 internal_error (__FILE__, __LINE__, 11558 _("aggregate apparently mangled")); 11559 } 11560 11561 ada_forward_operator_length (exp, pc, &oplen, &nargs); 11562 *pos += oplen - 1; 11563 for (tem = 0; tem < nargs; tem += 1) 11564 ada_evaluate_subexp (NULL, exp, pos, noside); 11565 goto nosideret; 11566 } 11567 11568nosideret: 11569 return eval_skip_value (exp); 11570} 11571 11572 11573 /* Fixed point */ 11574 11575/* If TYPE encodes an Ada fixed-point type, return the suffix of the 11576 type name that encodes the 'small and 'delta information. 11577 Otherwise, return NULL. */ 11578 11579static const char * 11580fixed_type_info (struct type *type) 11581{ 11582 const char *name = ada_type_name (type); 11583 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type); 11584 11585 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL) 11586 { 11587 const char *tail = strstr (name, "___XF_"); 11588 11589 if (tail == NULL) 11590 return NULL; 11591 else 11592 return tail + 5; 11593 } 11594 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type) 11595 return fixed_type_info (TYPE_TARGET_TYPE (type)); 11596 else 11597 return NULL; 11598} 11599 11600/* Returns non-zero iff TYPE represents an Ada fixed-point type. */ 11601 11602int 11603ada_is_fixed_point_type (struct type *type) 11604{ 11605 return fixed_type_info (type) != NULL; 11606} 11607 11608/* Return non-zero iff TYPE represents a System.Address type. */ 11609 11610int 11611ada_is_system_address_type (struct type *type) 11612{ 11613 return (TYPE_NAME (type) 11614 && strcmp (TYPE_NAME (type), "system__address") == 0); 11615} 11616 11617/* Assuming that TYPE is the representation of an Ada fixed-point 11618 type, return the target floating-point type to be used to represent 11619 of this type during internal computation. */ 11620 11621static struct type * 11622ada_scaling_type (struct type *type) 11623{ 11624 return builtin_type (get_type_arch (type))->builtin_long_double; 11625} 11626 11627/* Assuming that TYPE is the representation of an Ada fixed-point 11628 type, return its delta, or NULL if the type is malformed and the 11629 delta cannot be determined. */ 11630 11631struct value * 11632ada_delta (struct type *type) 11633{ 11634 const char *encoding = fixed_type_info (type); 11635 struct type *scale_type = ada_scaling_type (type); 11636 11637 long long num, den; 11638 11639 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2) 11640 return nullptr; 11641 else 11642 return value_binop (value_from_longest (scale_type, num), 11643 value_from_longest (scale_type, den), BINOP_DIV); 11644} 11645 11646/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling 11647 factor ('SMALL value) associated with the type. */ 11648 11649struct value * 11650ada_scaling_factor (struct type *type) 11651{ 11652 const char *encoding = fixed_type_info (type); 11653 struct type *scale_type = ada_scaling_type (type); 11654 11655 long long num0, den0, num1, den1; 11656 int n; 11657 11658 n = sscanf (encoding, "_%lld_%lld_%lld_%lld", 11659 &num0, &den0, &num1, &den1); 11660 11661 if (n < 2) 11662 return value_from_longest (scale_type, 1); 11663 else if (n == 4) 11664 return value_binop (value_from_longest (scale_type, num1), 11665 value_from_longest (scale_type, den1), BINOP_DIV); 11666 else 11667 return value_binop (value_from_longest (scale_type, num0), 11668 value_from_longest (scale_type, den0), BINOP_DIV); 11669} 11670 11671 11672 11673 /* Range types */ 11674 11675/* Scan STR beginning at position K for a discriminant name, and 11676 return the value of that discriminant field of DVAL in *PX. If 11677 PNEW_K is not null, put the position of the character beyond the 11678 name scanned in *PNEW_K. Return 1 if successful; return 0 and do 11679 not alter *PX and *PNEW_K if unsuccessful. */ 11680 11681static int 11682scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px, 11683 int *pnew_k) 11684{ 11685 static char *bound_buffer = NULL; 11686 static size_t bound_buffer_len = 0; 11687 const char *pstart, *pend, *bound; 11688 struct value *bound_val; 11689 11690 if (dval == NULL || str == NULL || str[k] == '\0') 11691 return 0; 11692 11693 pstart = str + k; 11694 pend = strstr (pstart, "__"); 11695 if (pend == NULL) 11696 { 11697 bound = pstart; 11698 k += strlen (bound); 11699 } 11700 else 11701 { 11702 int len = pend - pstart; 11703 11704 /* Strip __ and beyond. */ 11705 GROW_VECT (bound_buffer, bound_buffer_len, len + 1); 11706 strncpy (bound_buffer, pstart, len); 11707 bound_buffer[len] = '\0'; 11708 11709 bound = bound_buffer; 11710 k = pend - str; 11711 } 11712 11713 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval)); 11714 if (bound_val == NULL) 11715 return 0; 11716 11717 *px = value_as_long (bound_val); 11718 if (pnew_k != NULL) 11719 *pnew_k = k; 11720 return 1; 11721} 11722 11723/* Value of variable named NAME in the current environment. If 11724 no such variable found, then if ERR_MSG is null, returns 0, and 11725 otherwise causes an error with message ERR_MSG. */ 11726 11727static struct value * 11728get_var_value (const char *name, const char *err_msg) 11729{ 11730 lookup_name_info lookup_name (name, symbol_name_match_type::FULL); 11731 11732 std::vector<struct block_symbol> syms; 11733 int nsyms = ada_lookup_symbol_list_worker (lookup_name, 11734 get_selected_block (0), 11735 VAR_DOMAIN, &syms, 1); 11736 11737 if (nsyms != 1) 11738 { 11739 if (err_msg == NULL) 11740 return 0; 11741 else 11742 error (("%s"), err_msg); 11743 } 11744 11745 return value_of_variable (syms[0].symbol, syms[0].block); 11746} 11747 11748/* Value of integer variable named NAME in the current environment. 11749 If no such variable is found, returns false. Otherwise, sets VALUE 11750 to the variable's value and returns true. */ 11751 11752bool 11753get_int_var_value (const char *name, LONGEST &value) 11754{ 11755 struct value *var_val = get_var_value (name, 0); 11756 11757 if (var_val == 0) 11758 return false; 11759 11760 value = value_as_long (var_val); 11761 return true; 11762} 11763 11764 11765/* Return a range type whose base type is that of the range type named 11766 NAME in the current environment, and whose bounds are calculated 11767 from NAME according to the GNAT range encoding conventions. 11768 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the 11769 corresponding range type from debug information; fall back to using it 11770 if symbol lookup fails. If a new type must be created, allocate it 11771 like ORIG_TYPE was. The bounds information, in general, is encoded 11772 in NAME, the base type given in the named range type. */ 11773 11774static struct type * 11775to_fixed_range_type (struct type *raw_type, struct value *dval) 11776{ 11777 const char *name; 11778 struct type *base_type; 11779 const char *subtype_info; 11780 11781 gdb_assert (raw_type != NULL); 11782 gdb_assert (TYPE_NAME (raw_type) != NULL); 11783 11784 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE) 11785 base_type = TYPE_TARGET_TYPE (raw_type); 11786 else 11787 base_type = raw_type; 11788 11789 name = TYPE_NAME (raw_type); 11790 subtype_info = strstr (name, "___XD"); 11791 if (subtype_info == NULL) 11792 { 11793 LONGEST L = ada_discrete_type_low_bound (raw_type); 11794 LONGEST U = ada_discrete_type_high_bound (raw_type); 11795 11796 if (L < INT_MIN || U > INT_MAX) 11797 return raw_type; 11798 else 11799 return create_static_range_type (alloc_type_copy (raw_type), raw_type, 11800 L, U); 11801 } 11802 else 11803 { 11804 static char *name_buf = NULL; 11805 static size_t name_len = 0; 11806 int prefix_len = subtype_info - name; 11807 LONGEST L, U; 11808 struct type *type; 11809 const char *bounds_str; 11810 int n; 11811 11812 GROW_VECT (name_buf, name_len, prefix_len + 5); 11813 strncpy (name_buf, name, prefix_len); 11814 name_buf[prefix_len] = '\0'; 11815 11816 subtype_info += 5; 11817 bounds_str = strchr (subtype_info, '_'); 11818 n = 1; 11819 11820 if (*subtype_info == 'L') 11821 { 11822 if (!ada_scan_number (bounds_str, n, &L, &n) 11823 && !scan_discrim_bound (bounds_str, n, dval, &L, &n)) 11824 return raw_type; 11825 if (bounds_str[n] == '_') 11826 n += 2; 11827 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */ 11828 n += 1; 11829 subtype_info += 1; 11830 } 11831 else 11832 { 11833 strcpy (name_buf + prefix_len, "___L"); 11834 if (!get_int_var_value (name_buf, L)) 11835 { 11836 lim_warning (_("Unknown lower bound, using 1.")); 11837 L = 1; 11838 } 11839 } 11840 11841 if (*subtype_info == 'U') 11842 { 11843 if (!ada_scan_number (bounds_str, n, &U, &n) 11844 && !scan_discrim_bound (bounds_str, n, dval, &U, &n)) 11845 return raw_type; 11846 } 11847 else 11848 { 11849 strcpy (name_buf + prefix_len, "___U"); 11850 if (!get_int_var_value (name_buf, U)) 11851 { 11852 lim_warning (_("Unknown upper bound, using %ld."), (long) L); 11853 U = L; 11854 } 11855 } 11856 11857 type = create_static_range_type (alloc_type_copy (raw_type), 11858 base_type, L, U); 11859 /* create_static_range_type alters the resulting type's length 11860 to match the size of the base_type, which is not what we want. 11861 Set it back to the original range type's length. */ 11862 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type); 11863 TYPE_NAME (type) = name; 11864 return type; 11865 } 11866} 11867 11868/* True iff NAME is the name of a range type. */ 11869 11870int 11871ada_is_range_type_name (const char *name) 11872{ 11873 return (name != NULL && strstr (name, "___XD")); 11874} 11875 11876 11877 /* Modular types */ 11878 11879/* True iff TYPE is an Ada modular type. */ 11880 11881int 11882ada_is_modular_type (struct type *type) 11883{ 11884 struct type *subranged_type = get_base_type (type); 11885 11886 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE 11887 && TYPE_CODE (subranged_type) == TYPE_CODE_INT 11888 && TYPE_UNSIGNED (subranged_type)); 11889} 11890 11891/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */ 11892 11893ULONGEST 11894ada_modulus (struct type *type) 11895{ 11896 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1; 11897} 11898 11899 11900/* Ada exception catchpoint support: 11901 --------------------------------- 11902 11903 We support 3 kinds of exception catchpoints: 11904 . catchpoints on Ada exceptions 11905 . catchpoints on unhandled Ada exceptions 11906 . catchpoints on failed assertions 11907 11908 Exceptions raised during failed assertions, or unhandled exceptions 11909 could perfectly be caught with the general catchpoint on Ada exceptions. 11910 However, we can easily differentiate these two special cases, and having 11911 the option to distinguish these two cases from the rest can be useful 11912 to zero-in on certain situations. 11913 11914 Exception catchpoints are a specialized form of breakpoint, 11915 since they rely on inserting breakpoints inside known routines 11916 of the GNAT runtime. The implementation therefore uses a standard 11917 breakpoint structure of the BP_BREAKPOINT type, but with its own set 11918 of breakpoint_ops. 11919 11920 Support in the runtime for exception catchpoints have been changed 11921 a few times already, and these changes affect the implementation 11922 of these catchpoints. In order to be able to support several 11923 variants of the runtime, we use a sniffer that will determine 11924 the runtime variant used by the program being debugged. */ 11925 11926/* Ada's standard exceptions. 11927 11928 The Ada 83 standard also defined Numeric_Error. But there so many 11929 situations where it was unclear from the Ada 83 Reference Manual 11930 (RM) whether Constraint_Error or Numeric_Error should be raised, 11931 that the ARG (Ada Rapporteur Group) eventually issued a Binding 11932 Interpretation saying that anytime the RM says that Numeric_Error 11933 should be raised, the implementation may raise Constraint_Error. 11934 Ada 95 went one step further and pretty much removed Numeric_Error 11935 from the list of standard exceptions (it made it a renaming of 11936 Constraint_Error, to help preserve compatibility when compiling 11937 an Ada83 compiler). As such, we do not include Numeric_Error from 11938 this list of standard exceptions. */ 11939 11940static const char *standard_exc[] = { 11941 "constraint_error", 11942 "program_error", 11943 "storage_error", 11944 "tasking_error" 11945}; 11946 11947typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void); 11948 11949/* A structure that describes how to support exception catchpoints 11950 for a given executable. */ 11951 11952struct exception_support_info 11953{ 11954 /* The name of the symbol to break on in order to insert 11955 a catchpoint on exceptions. */ 11956 const char *catch_exception_sym; 11957 11958 /* The name of the symbol to break on in order to insert 11959 a catchpoint on unhandled exceptions. */ 11960 const char *catch_exception_unhandled_sym; 11961 11962 /* The name of the symbol to break on in order to insert 11963 a catchpoint on failed assertions. */ 11964 const char *catch_assert_sym; 11965 11966 /* The name of the symbol to break on in order to insert 11967 a catchpoint on exception handling. */ 11968 const char *catch_handlers_sym; 11969 11970 /* Assuming that the inferior just triggered an unhandled exception 11971 catchpoint, this function is responsible for returning the address 11972 in inferior memory where the name of that exception is stored. 11973 Return zero if the address could not be computed. */ 11974 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr; 11975}; 11976 11977static CORE_ADDR ada_unhandled_exception_name_addr (void); 11978static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void); 11979 11980/* The following exception support info structure describes how to 11981 implement exception catchpoints with the latest version of the 11982 Ada runtime (as of 2007-03-06). */ 11983 11984static const struct exception_support_info default_exception_support_info = 11985{ 11986 "__gnat_debug_raise_exception", /* catch_exception_sym */ 11987 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */ 11988 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */ 11989 "__gnat_begin_handler", /* catch_handlers_sym */ 11990 ada_unhandled_exception_name_addr 11991}; 11992 11993/* The following exception support info structure describes how to 11994 implement exception catchpoints with a slightly older version 11995 of the Ada runtime. */ 11996 11997static const struct exception_support_info exception_support_info_fallback = 11998{ 11999 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */ 12000 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */ 12001 "system__assertions__raise_assert_failure", /* catch_assert_sym */ 12002 "__gnat_begin_handler", /* catch_handlers_sym */ 12003 ada_unhandled_exception_name_addr_from_raise 12004}; 12005 12006/* Return nonzero if we can detect the exception support routines 12007 described in EINFO. 12008 12009 This function errors out if an abnormal situation is detected 12010 (for instance, if we find the exception support routines, but 12011 that support is found to be incomplete). */ 12012 12013static int 12014ada_has_this_exception_support (const struct exception_support_info *einfo) 12015{ 12016 struct symbol *sym; 12017 12018 /* The symbol we're looking up is provided by a unit in the GNAT runtime 12019 that should be compiled with debugging information. As a result, we 12020 expect to find that symbol in the symtabs. */ 12021 12022 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN); 12023 if (sym == NULL) 12024 { 12025 /* Perhaps we did not find our symbol because the Ada runtime was 12026 compiled without debugging info, or simply stripped of it. 12027 It happens on some GNU/Linux distributions for instance, where 12028 users have to install a separate debug package in order to get 12029 the runtime's debugging info. In that situation, let the user 12030 know why we cannot insert an Ada exception catchpoint. 12031 12032 Note: Just for the purpose of inserting our Ada exception 12033 catchpoint, we could rely purely on the associated minimal symbol. 12034 But we would be operating in degraded mode anyway, since we are 12035 still lacking the debugging info needed later on to extract 12036 the name of the exception being raised (this name is printed in 12037 the catchpoint message, and is also used when trying to catch 12038 a specific exception). We do not handle this case for now. */ 12039 struct bound_minimal_symbol msym 12040 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL); 12041 12042 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline) 12043 error (_("Your Ada runtime appears to be missing some debugging " 12044 "information.\nCannot insert Ada exception catchpoint " 12045 "in this configuration.")); 12046 12047 return 0; 12048 } 12049 12050 /* Make sure that the symbol we found corresponds to a function. */ 12051 12052 if (SYMBOL_CLASS (sym) != LOC_BLOCK) 12053 error (_("Symbol \"%s\" is not a function (class = %d)"), 12054 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym)); 12055 12056 return 1; 12057} 12058 12059/* Inspect the Ada runtime and determine which exception info structure 12060 should be used to provide support for exception catchpoints. 12061 12062 This function will always set the per-inferior exception_info, 12063 or raise an error. */ 12064 12065static void 12066ada_exception_support_info_sniffer (void) 12067{ 12068 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 12069 12070 /* If the exception info is already known, then no need to recompute it. */ 12071 if (data->exception_info != NULL) 12072 return; 12073 12074 /* Check the latest (default) exception support info. */ 12075 if (ada_has_this_exception_support (&default_exception_support_info)) 12076 { 12077 data->exception_info = &default_exception_support_info; 12078 return; 12079 } 12080 12081 /* Try our fallback exception suport info. */ 12082 if (ada_has_this_exception_support (&exception_support_info_fallback)) 12083 { 12084 data->exception_info = &exception_support_info_fallback; 12085 return; 12086 } 12087 12088 /* Sometimes, it is normal for us to not be able to find the routine 12089 we are looking for. This happens when the program is linked with 12090 the shared version of the GNAT runtime, and the program has not been 12091 started yet. Inform the user of these two possible causes if 12092 applicable. */ 12093 12094 if (ada_update_initial_language (language_unknown) != language_ada) 12095 error (_("Unable to insert catchpoint. Is this an Ada main program?")); 12096 12097 /* If the symbol does not exist, then check that the program is 12098 already started, to make sure that shared libraries have been 12099 loaded. If it is not started, this may mean that the symbol is 12100 in a shared library. */ 12101 12102 if (inferior_ptid.pid () == 0) 12103 error (_("Unable to insert catchpoint. Try to start the program first.")); 12104 12105 /* At this point, we know that we are debugging an Ada program and 12106 that the inferior has been started, but we still are not able to 12107 find the run-time symbols. That can mean that we are in 12108 configurable run time mode, or that a-except as been optimized 12109 out by the linker... In any case, at this point it is not worth 12110 supporting this feature. */ 12111 12112 error (_("Cannot insert Ada exception catchpoints in this configuration.")); 12113} 12114 12115/* True iff FRAME is very likely to be that of a function that is 12116 part of the runtime system. This is all very heuristic, but is 12117 intended to be used as advice as to what frames are uninteresting 12118 to most users. */ 12119 12120static int 12121is_known_support_routine (struct frame_info *frame) 12122{ 12123 enum language func_lang; 12124 int i; 12125 const char *fullname; 12126 12127 /* If this code does not have any debugging information (no symtab), 12128 This cannot be any user code. */ 12129 12130 symtab_and_line sal = find_frame_sal (frame); 12131 if (sal.symtab == NULL) 12132 return 1; 12133 12134 /* If there is a symtab, but the associated source file cannot be 12135 located, then assume this is not user code: Selecting a frame 12136 for which we cannot display the code would not be very helpful 12137 for the user. This should also take care of case such as VxWorks 12138 where the kernel has some debugging info provided for a few units. */ 12139 12140 fullname = symtab_to_fullname (sal.symtab); 12141 if (access (fullname, R_OK) != 0) 12142 return 1; 12143 12144 /* Check the unit filename againt the Ada runtime file naming. 12145 We also check the name of the objfile against the name of some 12146 known system libraries that sometimes come with debugging info 12147 too. */ 12148 12149 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1) 12150 { 12151 re_comp (known_runtime_file_name_patterns[i]); 12152 if (re_exec (lbasename (sal.symtab->filename))) 12153 return 1; 12154 if (SYMTAB_OBJFILE (sal.symtab) != NULL 12155 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab)))) 12156 return 1; 12157 } 12158 12159 /* Check whether the function is a GNAT-generated entity. */ 12160 12161 gdb::unique_xmalloc_ptr<char> func_name 12162 = find_frame_funname (frame, &func_lang, NULL); 12163 if (func_name == NULL) 12164 return 1; 12165 12166 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1) 12167 { 12168 re_comp (known_auxiliary_function_name_patterns[i]); 12169 if (re_exec (func_name.get ())) 12170 return 1; 12171 } 12172 12173 return 0; 12174} 12175 12176/* Find the first frame that contains debugging information and that is not 12177 part of the Ada run-time, starting from FI and moving upward. */ 12178 12179void 12180ada_find_printable_frame (struct frame_info *fi) 12181{ 12182 for (; fi != NULL; fi = get_prev_frame (fi)) 12183 { 12184 if (!is_known_support_routine (fi)) 12185 { 12186 select_frame (fi); 12187 break; 12188 } 12189 } 12190 12191} 12192 12193/* Assuming that the inferior just triggered an unhandled exception 12194 catchpoint, return the address in inferior memory where the name 12195 of the exception is stored. 12196 12197 Return zero if the address could not be computed. */ 12198 12199static CORE_ADDR 12200ada_unhandled_exception_name_addr (void) 12201{ 12202 return parse_and_eval_address ("e.full_name"); 12203} 12204 12205/* Same as ada_unhandled_exception_name_addr, except that this function 12206 should be used when the inferior uses an older version of the runtime, 12207 where the exception name needs to be extracted from a specific frame 12208 several frames up in the callstack. */ 12209 12210static CORE_ADDR 12211ada_unhandled_exception_name_addr_from_raise (void) 12212{ 12213 int frame_level; 12214 struct frame_info *fi; 12215 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 12216 12217 /* To determine the name of this exception, we need to select 12218 the frame corresponding to RAISE_SYM_NAME. This frame is 12219 at least 3 levels up, so we simply skip the first 3 frames 12220 without checking the name of their associated function. */ 12221 fi = get_current_frame (); 12222 for (frame_level = 0; frame_level < 3; frame_level += 1) 12223 if (fi != NULL) 12224 fi = get_prev_frame (fi); 12225 12226 while (fi != NULL) 12227 { 12228 enum language func_lang; 12229 12230 gdb::unique_xmalloc_ptr<char> func_name 12231 = find_frame_funname (fi, &func_lang, NULL); 12232 if (func_name != NULL) 12233 { 12234 if (strcmp (func_name.get (), 12235 data->exception_info->catch_exception_sym) == 0) 12236 break; /* We found the frame we were looking for... */ 12237 } 12238 fi = get_prev_frame (fi); 12239 } 12240 12241 if (fi == NULL) 12242 return 0; 12243 12244 select_frame (fi); 12245 return parse_and_eval_address ("id.full_name"); 12246} 12247 12248/* Assuming the inferior just triggered an Ada exception catchpoint 12249 (of any type), return the address in inferior memory where the name 12250 of the exception is stored, if applicable. 12251 12252 Assumes the selected frame is the current frame. 12253 12254 Return zero if the address could not be computed, or if not relevant. */ 12255 12256static CORE_ADDR 12257ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex, 12258 struct breakpoint *b) 12259{ 12260 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 12261 12262 switch (ex) 12263 { 12264 case ada_catch_exception: 12265 return (parse_and_eval_address ("e.full_name")); 12266 break; 12267 12268 case ada_catch_exception_unhandled: 12269 return data->exception_info->unhandled_exception_name_addr (); 12270 break; 12271 12272 case ada_catch_handlers: 12273 return 0; /* The runtimes does not provide access to the exception 12274 name. */ 12275 break; 12276 12277 case ada_catch_assert: 12278 return 0; /* Exception name is not relevant in this case. */ 12279 break; 12280 12281 default: 12282 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 12283 break; 12284 } 12285 12286 return 0; /* Should never be reached. */ 12287} 12288 12289/* Assuming the inferior is stopped at an exception catchpoint, 12290 return the message which was associated to the exception, if 12291 available. Return NULL if the message could not be retrieved. 12292 12293 Note: The exception message can be associated to an exception 12294 either through the use of the Raise_Exception function, or 12295 more simply (Ada 2005 and later), via: 12296 12297 raise Exception_Name with "exception message"; 12298 12299 */ 12300 12301static gdb::unique_xmalloc_ptr<char> 12302ada_exception_message_1 (void) 12303{ 12304 struct value *e_msg_val; 12305 int e_msg_len; 12306 12307 /* For runtimes that support this feature, the exception message 12308 is passed as an unbounded string argument called "message". */ 12309 e_msg_val = parse_and_eval ("message"); 12310 if (e_msg_val == NULL) 12311 return NULL; /* Exception message not supported. */ 12312 12313 e_msg_val = ada_coerce_to_simple_array (e_msg_val); 12314 gdb_assert (e_msg_val != NULL); 12315 e_msg_len = TYPE_LENGTH (value_type (e_msg_val)); 12316 12317 /* If the message string is empty, then treat it as if there was 12318 no exception message. */ 12319 if (e_msg_len <= 0) 12320 return NULL; 12321 12322 gdb::unique_xmalloc_ptr<char> e_msg ((char *) xmalloc (e_msg_len + 1)); 12323 read_memory_string (value_address (e_msg_val), e_msg.get (), e_msg_len + 1); 12324 e_msg.get ()[e_msg_len] = '\0'; 12325 12326 return e_msg; 12327} 12328 12329/* Same as ada_exception_message_1, except that all exceptions are 12330 contained here (returning NULL instead). */ 12331 12332static gdb::unique_xmalloc_ptr<char> 12333ada_exception_message (void) 12334{ 12335 gdb::unique_xmalloc_ptr<char> e_msg; 12336 12337 TRY 12338 { 12339 e_msg = ada_exception_message_1 (); 12340 } 12341 CATCH (e, RETURN_MASK_ERROR) 12342 { 12343 e_msg.reset (nullptr); 12344 } 12345 END_CATCH 12346 12347 return e_msg; 12348} 12349 12350/* Same as ada_exception_name_addr_1, except that it intercepts and contains 12351 any error that ada_exception_name_addr_1 might cause to be thrown. 12352 When an error is intercepted, a warning with the error message is printed, 12353 and zero is returned. */ 12354 12355static CORE_ADDR 12356ada_exception_name_addr (enum ada_exception_catchpoint_kind ex, 12357 struct breakpoint *b) 12358{ 12359 CORE_ADDR result = 0; 12360 12361 TRY 12362 { 12363 result = ada_exception_name_addr_1 (ex, b); 12364 } 12365 12366 CATCH (e, RETURN_MASK_ERROR) 12367 { 12368 warning (_("failed to get exception name: %s"), e.message); 12369 return 0; 12370 } 12371 END_CATCH 12372 12373 return result; 12374} 12375 12376static std::string ada_exception_catchpoint_cond_string 12377 (const char *excep_string, 12378 enum ada_exception_catchpoint_kind ex); 12379 12380/* Ada catchpoints. 12381 12382 In the case of catchpoints on Ada exceptions, the catchpoint will 12383 stop the target on every exception the program throws. When a user 12384 specifies the name of a specific exception, we translate this 12385 request into a condition expression (in text form), and then parse 12386 it into an expression stored in each of the catchpoint's locations. 12387 We then use this condition to check whether the exception that was 12388 raised is the one the user is interested in. If not, then the 12389 target is resumed again. We store the name of the requested 12390 exception, in order to be able to re-set the condition expression 12391 when symbols change. */ 12392 12393/* An instance of this type is used to represent an Ada catchpoint 12394 breakpoint location. */ 12395 12396class ada_catchpoint_location : public bp_location 12397{ 12398public: 12399 ada_catchpoint_location (breakpoint *owner) 12400 : bp_location (owner) 12401 {} 12402 12403 /* The condition that checks whether the exception that was raised 12404 is the specific exception the user specified on catchpoint 12405 creation. */ 12406 expression_up excep_cond_expr; 12407}; 12408 12409/* An instance of this type is used to represent an Ada catchpoint. */ 12410 12411struct ada_catchpoint : public breakpoint 12412{ 12413 /* The name of the specific exception the user specified. */ 12414 std::string excep_string; 12415}; 12416 12417/* Parse the exception condition string in the context of each of the 12418 catchpoint's locations, and store them for later evaluation. */ 12419 12420static void 12421create_excep_cond_exprs (struct ada_catchpoint *c, 12422 enum ada_exception_catchpoint_kind ex) 12423{ 12424 struct bp_location *bl; 12425 12426 /* Nothing to do if there's no specific exception to catch. */ 12427 if (c->excep_string.empty ()) 12428 return; 12429 12430 /* Same if there are no locations... */ 12431 if (c->loc == NULL) 12432 return; 12433 12434 /* Compute the condition expression in text form, from the specific 12435 expection we want to catch. */ 12436 std::string cond_string 12437 = ada_exception_catchpoint_cond_string (c->excep_string.c_str (), ex); 12438 12439 /* Iterate over all the catchpoint's locations, and parse an 12440 expression for each. */ 12441 for (bl = c->loc; bl != NULL; bl = bl->next) 12442 { 12443 struct ada_catchpoint_location *ada_loc 12444 = (struct ada_catchpoint_location *) bl; 12445 expression_up exp; 12446 12447 if (!bl->shlib_disabled) 12448 { 12449 const char *s; 12450 12451 s = cond_string.c_str (); 12452 TRY 12453 { 12454 exp = parse_exp_1 (&s, bl->address, 12455 block_for_pc (bl->address), 12456 0); 12457 } 12458 CATCH (e, RETURN_MASK_ERROR) 12459 { 12460 warning (_("failed to reevaluate internal exception condition " 12461 "for catchpoint %d: %s"), 12462 c->number, e.message); 12463 } 12464 END_CATCH 12465 } 12466 12467 ada_loc->excep_cond_expr = std::move (exp); 12468 } 12469} 12470 12471/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops 12472 structure for all exception catchpoint kinds. */ 12473 12474static struct bp_location * 12475allocate_location_exception (enum ada_exception_catchpoint_kind ex, 12476 struct breakpoint *self) 12477{ 12478 return new ada_catchpoint_location (self); 12479} 12480 12481/* Implement the RE_SET method in the breakpoint_ops structure for all 12482 exception catchpoint kinds. */ 12483 12484static void 12485re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b) 12486{ 12487 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12488 12489 /* Call the base class's method. This updates the catchpoint's 12490 locations. */ 12491 bkpt_breakpoint_ops.re_set (b); 12492 12493 /* Reparse the exception conditional expressions. One for each 12494 location. */ 12495 create_excep_cond_exprs (c, ex); 12496} 12497 12498/* Returns true if we should stop for this breakpoint hit. If the 12499 user specified a specific exception, we only want to cause a stop 12500 if the program thrown that exception. */ 12501 12502static int 12503should_stop_exception (const struct bp_location *bl) 12504{ 12505 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner; 12506 const struct ada_catchpoint_location *ada_loc 12507 = (const struct ada_catchpoint_location *) bl; 12508 int stop; 12509 12510 /* With no specific exception, should always stop. */ 12511 if (c->excep_string.empty ()) 12512 return 1; 12513 12514 if (ada_loc->excep_cond_expr == NULL) 12515 { 12516 /* We will have a NULL expression if back when we were creating 12517 the expressions, this location's had failed to parse. */ 12518 return 1; 12519 } 12520 12521 stop = 1; 12522 TRY 12523 { 12524 struct value *mark; 12525 12526 mark = value_mark (); 12527 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ())); 12528 value_free_to_mark (mark); 12529 } 12530 CATCH (ex, RETURN_MASK_ALL) 12531 { 12532 exception_fprintf (gdb_stderr, ex, 12533 _("Error in testing exception condition:\n")); 12534 } 12535 END_CATCH 12536 12537 return stop; 12538} 12539 12540/* Implement the CHECK_STATUS method in the breakpoint_ops structure 12541 for all exception catchpoint kinds. */ 12542 12543static void 12544check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs) 12545{ 12546 bs->stop = should_stop_exception (bs->bp_location_at); 12547} 12548 12549/* Implement the PRINT_IT method in the breakpoint_ops structure 12550 for all exception catchpoint kinds. */ 12551 12552static enum print_stop_action 12553print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs) 12554{ 12555 struct ui_out *uiout = current_uiout; 12556 struct breakpoint *b = bs->breakpoint_at; 12557 12558 annotate_catchpoint (b->number); 12559 12560 if (uiout->is_mi_like_p ()) 12561 { 12562 uiout->field_string ("reason", 12563 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT)); 12564 uiout->field_string ("disp", bpdisp_text (b->disposition)); 12565 } 12566 12567 uiout->text (b->disposition == disp_del 12568 ? "\nTemporary catchpoint " : "\nCatchpoint "); 12569 uiout->field_int ("bkptno", b->number); 12570 uiout->text (", "); 12571 12572 /* ada_exception_name_addr relies on the selected frame being the 12573 current frame. Need to do this here because this function may be 12574 called more than once when printing a stop, and below, we'll 12575 select the first frame past the Ada run-time (see 12576 ada_find_printable_frame). */ 12577 select_frame (get_current_frame ()); 12578 12579 switch (ex) 12580 { 12581 case ada_catch_exception: 12582 case ada_catch_exception_unhandled: 12583 case ada_catch_handlers: 12584 { 12585 const CORE_ADDR addr = ada_exception_name_addr (ex, b); 12586 char exception_name[256]; 12587 12588 if (addr != 0) 12589 { 12590 read_memory (addr, (gdb_byte *) exception_name, 12591 sizeof (exception_name) - 1); 12592 exception_name [sizeof (exception_name) - 1] = '\0'; 12593 } 12594 else 12595 { 12596 /* For some reason, we were unable to read the exception 12597 name. This could happen if the Runtime was compiled 12598 without debugging info, for instance. In that case, 12599 just replace the exception name by the generic string 12600 "exception" - it will read as "an exception" in the 12601 notification we are about to print. */ 12602 memcpy (exception_name, "exception", sizeof ("exception")); 12603 } 12604 /* In the case of unhandled exception breakpoints, we print 12605 the exception name as "unhandled EXCEPTION_NAME", to make 12606 it clearer to the user which kind of catchpoint just got 12607 hit. We used ui_out_text to make sure that this extra 12608 info does not pollute the exception name in the MI case. */ 12609 if (ex == ada_catch_exception_unhandled) 12610 uiout->text ("unhandled "); 12611 uiout->field_string ("exception-name", exception_name); 12612 } 12613 break; 12614 case ada_catch_assert: 12615 /* In this case, the name of the exception is not really 12616 important. Just print "failed assertion" to make it clearer 12617 that his program just hit an assertion-failure catchpoint. 12618 We used ui_out_text because this info does not belong in 12619 the MI output. */ 12620 uiout->text ("failed assertion"); 12621 break; 12622 } 12623 12624 gdb::unique_xmalloc_ptr<char> exception_message = ada_exception_message (); 12625 if (exception_message != NULL) 12626 { 12627 uiout->text (" ("); 12628 uiout->field_string ("exception-message", exception_message.get ()); 12629 uiout->text (")"); 12630 } 12631 12632 uiout->text (" at "); 12633 ada_find_printable_frame (get_current_frame ()); 12634 12635 return PRINT_SRC_AND_LOC; 12636} 12637 12638/* Implement the PRINT_ONE method in the breakpoint_ops structure 12639 for all exception catchpoint kinds. */ 12640 12641static void 12642print_one_exception (enum ada_exception_catchpoint_kind ex, 12643 struct breakpoint *b, struct bp_location **last_loc) 12644{ 12645 struct ui_out *uiout = current_uiout; 12646 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12647 struct value_print_options opts; 12648 12649 get_user_print_options (&opts); 12650 if (opts.addressprint) 12651 { 12652 annotate_field (4); 12653 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address); 12654 } 12655 12656 annotate_field (5); 12657 *last_loc = b->loc; 12658 switch (ex) 12659 { 12660 case ada_catch_exception: 12661 if (!c->excep_string.empty ()) 12662 { 12663 std::string msg = string_printf (_("`%s' Ada exception"), 12664 c->excep_string.c_str ()); 12665 12666 uiout->field_string ("what", msg); 12667 } 12668 else 12669 uiout->field_string ("what", "all Ada exceptions"); 12670 12671 break; 12672 12673 case ada_catch_exception_unhandled: 12674 uiout->field_string ("what", "unhandled Ada exceptions"); 12675 break; 12676 12677 case ada_catch_handlers: 12678 if (!c->excep_string.empty ()) 12679 { 12680 uiout->field_fmt ("what", 12681 _("`%s' Ada exception handlers"), 12682 c->excep_string.c_str ()); 12683 } 12684 else 12685 uiout->field_string ("what", "all Ada exceptions handlers"); 12686 break; 12687 12688 case ada_catch_assert: 12689 uiout->field_string ("what", "failed Ada assertions"); 12690 break; 12691 12692 default: 12693 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 12694 break; 12695 } 12696} 12697 12698/* Implement the PRINT_MENTION method in the breakpoint_ops structure 12699 for all exception catchpoint kinds. */ 12700 12701static void 12702print_mention_exception (enum ada_exception_catchpoint_kind ex, 12703 struct breakpoint *b) 12704{ 12705 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12706 struct ui_out *uiout = current_uiout; 12707 12708 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ") 12709 : _("Catchpoint ")); 12710 uiout->field_int ("bkptno", b->number); 12711 uiout->text (": "); 12712 12713 switch (ex) 12714 { 12715 case ada_catch_exception: 12716 if (!c->excep_string.empty ()) 12717 { 12718 std::string info = string_printf (_("`%s' Ada exception"), 12719 c->excep_string.c_str ()); 12720 uiout->text (info.c_str ()); 12721 } 12722 else 12723 uiout->text (_("all Ada exceptions")); 12724 break; 12725 12726 case ada_catch_exception_unhandled: 12727 uiout->text (_("unhandled Ada exceptions")); 12728 break; 12729 12730 case ada_catch_handlers: 12731 if (!c->excep_string.empty ()) 12732 { 12733 std::string info 12734 = string_printf (_("`%s' Ada exception handlers"), 12735 c->excep_string.c_str ()); 12736 uiout->text (info.c_str ()); 12737 } 12738 else 12739 uiout->text (_("all Ada exceptions handlers")); 12740 break; 12741 12742 case ada_catch_assert: 12743 uiout->text (_("failed Ada assertions")); 12744 break; 12745 12746 default: 12747 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 12748 break; 12749 } 12750} 12751 12752/* Implement the PRINT_RECREATE method in the breakpoint_ops structure 12753 for all exception catchpoint kinds. */ 12754 12755static void 12756print_recreate_exception (enum ada_exception_catchpoint_kind ex, 12757 struct breakpoint *b, struct ui_file *fp) 12758{ 12759 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12760 12761 switch (ex) 12762 { 12763 case ada_catch_exception: 12764 fprintf_filtered (fp, "catch exception"); 12765 if (!c->excep_string.empty ()) 12766 fprintf_filtered (fp, " %s", c->excep_string.c_str ()); 12767 break; 12768 12769 case ada_catch_exception_unhandled: 12770 fprintf_filtered (fp, "catch exception unhandled"); 12771 break; 12772 12773 case ada_catch_handlers: 12774 fprintf_filtered (fp, "catch handlers"); 12775 break; 12776 12777 case ada_catch_assert: 12778 fprintf_filtered (fp, "catch assert"); 12779 break; 12780 12781 default: 12782 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 12783 } 12784 print_recreate_thread (b, fp); 12785} 12786 12787/* Virtual table for "catch exception" breakpoints. */ 12788 12789static struct bp_location * 12790allocate_location_catch_exception (struct breakpoint *self) 12791{ 12792 return allocate_location_exception (ada_catch_exception, self); 12793} 12794 12795static void 12796re_set_catch_exception (struct breakpoint *b) 12797{ 12798 re_set_exception (ada_catch_exception, b); 12799} 12800 12801static void 12802check_status_catch_exception (bpstat bs) 12803{ 12804 check_status_exception (ada_catch_exception, bs); 12805} 12806 12807static enum print_stop_action 12808print_it_catch_exception (bpstat bs) 12809{ 12810 return print_it_exception (ada_catch_exception, bs); 12811} 12812 12813static void 12814print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc) 12815{ 12816 print_one_exception (ada_catch_exception, b, last_loc); 12817} 12818 12819static void 12820print_mention_catch_exception (struct breakpoint *b) 12821{ 12822 print_mention_exception (ada_catch_exception, b); 12823} 12824 12825static void 12826print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp) 12827{ 12828 print_recreate_exception (ada_catch_exception, b, fp); 12829} 12830 12831static struct breakpoint_ops catch_exception_breakpoint_ops; 12832 12833/* Virtual table for "catch exception unhandled" breakpoints. */ 12834 12835static struct bp_location * 12836allocate_location_catch_exception_unhandled (struct breakpoint *self) 12837{ 12838 return allocate_location_exception (ada_catch_exception_unhandled, self); 12839} 12840 12841static void 12842re_set_catch_exception_unhandled (struct breakpoint *b) 12843{ 12844 re_set_exception (ada_catch_exception_unhandled, b); 12845} 12846 12847static void 12848check_status_catch_exception_unhandled (bpstat bs) 12849{ 12850 check_status_exception (ada_catch_exception_unhandled, bs); 12851} 12852 12853static enum print_stop_action 12854print_it_catch_exception_unhandled (bpstat bs) 12855{ 12856 return print_it_exception (ada_catch_exception_unhandled, bs); 12857} 12858 12859static void 12860print_one_catch_exception_unhandled (struct breakpoint *b, 12861 struct bp_location **last_loc) 12862{ 12863 print_one_exception (ada_catch_exception_unhandled, b, last_loc); 12864} 12865 12866static void 12867print_mention_catch_exception_unhandled (struct breakpoint *b) 12868{ 12869 print_mention_exception (ada_catch_exception_unhandled, b); 12870} 12871 12872static void 12873print_recreate_catch_exception_unhandled (struct breakpoint *b, 12874 struct ui_file *fp) 12875{ 12876 print_recreate_exception (ada_catch_exception_unhandled, b, fp); 12877} 12878 12879static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops; 12880 12881/* Virtual table for "catch assert" breakpoints. */ 12882 12883static struct bp_location * 12884allocate_location_catch_assert (struct breakpoint *self) 12885{ 12886 return allocate_location_exception (ada_catch_assert, self); 12887} 12888 12889static void 12890re_set_catch_assert (struct breakpoint *b) 12891{ 12892 re_set_exception (ada_catch_assert, b); 12893} 12894 12895static void 12896check_status_catch_assert (bpstat bs) 12897{ 12898 check_status_exception (ada_catch_assert, bs); 12899} 12900 12901static enum print_stop_action 12902print_it_catch_assert (bpstat bs) 12903{ 12904 return print_it_exception (ada_catch_assert, bs); 12905} 12906 12907static void 12908print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc) 12909{ 12910 print_one_exception (ada_catch_assert, b, last_loc); 12911} 12912 12913static void 12914print_mention_catch_assert (struct breakpoint *b) 12915{ 12916 print_mention_exception (ada_catch_assert, b); 12917} 12918 12919static void 12920print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp) 12921{ 12922 print_recreate_exception (ada_catch_assert, b, fp); 12923} 12924 12925static struct breakpoint_ops catch_assert_breakpoint_ops; 12926 12927/* Virtual table for "catch handlers" breakpoints. */ 12928 12929static struct bp_location * 12930allocate_location_catch_handlers (struct breakpoint *self) 12931{ 12932 return allocate_location_exception (ada_catch_handlers, self); 12933} 12934 12935static void 12936re_set_catch_handlers (struct breakpoint *b) 12937{ 12938 re_set_exception (ada_catch_handlers, b); 12939} 12940 12941static void 12942check_status_catch_handlers (bpstat bs) 12943{ 12944 check_status_exception (ada_catch_handlers, bs); 12945} 12946 12947static enum print_stop_action 12948print_it_catch_handlers (bpstat bs) 12949{ 12950 return print_it_exception (ada_catch_handlers, bs); 12951} 12952 12953static void 12954print_one_catch_handlers (struct breakpoint *b, 12955 struct bp_location **last_loc) 12956{ 12957 print_one_exception (ada_catch_handlers, b, last_loc); 12958} 12959 12960static void 12961print_mention_catch_handlers (struct breakpoint *b) 12962{ 12963 print_mention_exception (ada_catch_handlers, b); 12964} 12965 12966static void 12967print_recreate_catch_handlers (struct breakpoint *b, 12968 struct ui_file *fp) 12969{ 12970 print_recreate_exception (ada_catch_handlers, b, fp); 12971} 12972 12973static struct breakpoint_ops catch_handlers_breakpoint_ops; 12974 12975/* Split the arguments specified in a "catch exception" command. 12976 Set EX to the appropriate catchpoint type. 12977 Set EXCEP_STRING to the name of the specific exception if 12978 specified by the user. 12979 IS_CATCH_HANDLERS_CMD: True if the arguments are for a 12980 "catch handlers" command. False otherwise. 12981 If a condition is found at the end of the arguments, the condition 12982 expression is stored in COND_STRING (memory must be deallocated 12983 after use). Otherwise COND_STRING is set to NULL. */ 12984 12985static void 12986catch_ada_exception_command_split (const char *args, 12987 bool is_catch_handlers_cmd, 12988 enum ada_exception_catchpoint_kind *ex, 12989 std::string *excep_string, 12990 std::string *cond_string) 12991{ 12992 std::string exception_name; 12993 12994 exception_name = extract_arg (&args); 12995 if (exception_name == "if") 12996 { 12997 /* This is not an exception name; this is the start of a condition 12998 expression for a catchpoint on all exceptions. So, "un-get" 12999 this token, and set exception_name to NULL. */ 13000 exception_name.clear (); 13001 args -= 2; 13002 } 13003 13004 /* Check to see if we have a condition. */ 13005 13006 args = skip_spaces (args); 13007 if (startswith (args, "if") 13008 && (isspace (args[2]) || args[2] == '\0')) 13009 { 13010 args += 2; 13011 args = skip_spaces (args); 13012 13013 if (args[0] == '\0') 13014 error (_("Condition missing after `if' keyword")); 13015 *cond_string = args; 13016 13017 args += strlen (args); 13018 } 13019 13020 /* Check that we do not have any more arguments. Anything else 13021 is unexpected. */ 13022 13023 if (args[0] != '\0') 13024 error (_("Junk at end of expression")); 13025 13026 if (is_catch_handlers_cmd) 13027 { 13028 /* Catch handling of exceptions. */ 13029 *ex = ada_catch_handlers; 13030 *excep_string = exception_name; 13031 } 13032 else if (exception_name.empty ()) 13033 { 13034 /* Catch all exceptions. */ 13035 *ex = ada_catch_exception; 13036 excep_string->clear (); 13037 } 13038 else if (exception_name == "unhandled") 13039 { 13040 /* Catch unhandled exceptions. */ 13041 *ex = ada_catch_exception_unhandled; 13042 excep_string->clear (); 13043 } 13044 else 13045 { 13046 /* Catch a specific exception. */ 13047 *ex = ada_catch_exception; 13048 *excep_string = exception_name; 13049 } 13050} 13051 13052/* Return the name of the symbol on which we should break in order to 13053 implement a catchpoint of the EX kind. */ 13054 13055static const char * 13056ada_exception_sym_name (enum ada_exception_catchpoint_kind ex) 13057{ 13058 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 13059 13060 gdb_assert (data->exception_info != NULL); 13061 13062 switch (ex) 13063 { 13064 case ada_catch_exception: 13065 return (data->exception_info->catch_exception_sym); 13066 break; 13067 case ada_catch_exception_unhandled: 13068 return (data->exception_info->catch_exception_unhandled_sym); 13069 break; 13070 case ada_catch_assert: 13071 return (data->exception_info->catch_assert_sym); 13072 break; 13073 case ada_catch_handlers: 13074 return (data->exception_info->catch_handlers_sym); 13075 break; 13076 default: 13077 internal_error (__FILE__, __LINE__, 13078 _("unexpected catchpoint kind (%d)"), ex); 13079 } 13080} 13081 13082/* Return the breakpoint ops "virtual table" used for catchpoints 13083 of the EX kind. */ 13084 13085static const struct breakpoint_ops * 13086ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex) 13087{ 13088 switch (ex) 13089 { 13090 case ada_catch_exception: 13091 return (&catch_exception_breakpoint_ops); 13092 break; 13093 case ada_catch_exception_unhandled: 13094 return (&catch_exception_unhandled_breakpoint_ops); 13095 break; 13096 case ada_catch_assert: 13097 return (&catch_assert_breakpoint_ops); 13098 break; 13099 case ada_catch_handlers: 13100 return (&catch_handlers_breakpoint_ops); 13101 break; 13102 default: 13103 internal_error (__FILE__, __LINE__, 13104 _("unexpected catchpoint kind (%d)"), ex); 13105 } 13106} 13107 13108/* Return the condition that will be used to match the current exception 13109 being raised with the exception that the user wants to catch. This 13110 assumes that this condition is used when the inferior just triggered 13111 an exception catchpoint. 13112 EX: the type of catchpoints used for catching Ada exceptions. */ 13113 13114static std::string 13115ada_exception_catchpoint_cond_string (const char *excep_string, 13116 enum ada_exception_catchpoint_kind ex) 13117{ 13118 int i; 13119 bool is_standard_exc = false; 13120 std::string result; 13121 13122 if (ex == ada_catch_handlers) 13123 { 13124 /* For exception handlers catchpoints, the condition string does 13125 not use the same parameter as for the other exceptions. */ 13126 result = ("long_integer (GNAT_GCC_exception_Access" 13127 "(gcc_exception).all.occurrence.id)"); 13128 } 13129 else 13130 result = "long_integer (e)"; 13131 13132 /* The standard exceptions are a special case. They are defined in 13133 runtime units that have been compiled without debugging info; if 13134 EXCEP_STRING is the not-fully-qualified name of a standard 13135 exception (e.g. "constraint_error") then, during the evaluation 13136 of the condition expression, the symbol lookup on this name would 13137 *not* return this standard exception. The catchpoint condition 13138 may then be set only on user-defined exceptions which have the 13139 same not-fully-qualified name (e.g. my_package.constraint_error). 13140 13141 To avoid this unexcepted behavior, these standard exceptions are 13142 systematically prefixed by "standard". This means that "catch 13143 exception constraint_error" is rewritten into "catch exception 13144 standard.constraint_error". 13145 13146 If an exception named contraint_error is defined in another package of 13147 the inferior program, then the only way to specify this exception as a 13148 breakpoint condition is to use its fully-qualified named: 13149 e.g. my_package.constraint_error. */ 13150 13151 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++) 13152 { 13153 if (strcmp (standard_exc [i], excep_string) == 0) 13154 { 13155 is_standard_exc = true; 13156 break; 13157 } 13158 } 13159 13160 result += " = "; 13161 13162 if (is_standard_exc) 13163 string_appendf (result, "long_integer (&standard.%s)", excep_string); 13164 else 13165 string_appendf (result, "long_integer (&%s)", excep_string); 13166 13167 return result; 13168} 13169 13170/* Return the symtab_and_line that should be used to insert an exception 13171 catchpoint of the TYPE kind. 13172 13173 ADDR_STRING returns the name of the function where the real 13174 breakpoint that implements the catchpoints is set, depending on the 13175 type of catchpoint we need to create. */ 13176 13177static struct symtab_and_line 13178ada_exception_sal (enum ada_exception_catchpoint_kind ex, 13179 std::string *addr_string, const struct breakpoint_ops **ops) 13180{ 13181 const char *sym_name; 13182 struct symbol *sym; 13183 13184 /* First, find out which exception support info to use. */ 13185 ada_exception_support_info_sniffer (); 13186 13187 /* Then lookup the function on which we will break in order to catch 13188 the Ada exceptions requested by the user. */ 13189 sym_name = ada_exception_sym_name (ex); 13190 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN); 13191 13192 if (sym == NULL) 13193 error (_("Catchpoint symbol not found: %s"), sym_name); 13194 13195 if (SYMBOL_CLASS (sym) != LOC_BLOCK) 13196 error (_("Unable to insert catchpoint. %s is not a function."), sym_name); 13197 13198 /* Set ADDR_STRING. */ 13199 *addr_string = sym_name; 13200 13201 /* Set OPS. */ 13202 *ops = ada_exception_breakpoint_ops (ex); 13203 13204 return find_function_start_sal (sym, 1); 13205} 13206 13207/* Create an Ada exception catchpoint. 13208 13209 EX_KIND is the kind of exception catchpoint to be created. 13210 13211 If EXCEPT_STRING is empty, this catchpoint is expected to trigger 13212 for all exceptions. Otherwise, EXCEPT_STRING indicates the name 13213 of the exception to which this catchpoint applies. 13214 13215 COND_STRING, if not empty, is the catchpoint condition. 13216 13217 TEMPFLAG, if nonzero, means that the underlying breakpoint 13218 should be temporary. 13219 13220 FROM_TTY is the usual argument passed to all commands implementations. */ 13221 13222void 13223create_ada_exception_catchpoint (struct gdbarch *gdbarch, 13224 enum ada_exception_catchpoint_kind ex_kind, 13225 const std::string &excep_string, 13226 const std::string &cond_string, 13227 int tempflag, 13228 int disabled, 13229 int from_tty) 13230{ 13231 std::string addr_string; 13232 const struct breakpoint_ops *ops = NULL; 13233 struct symtab_and_line sal = ada_exception_sal (ex_kind, &addr_string, &ops); 13234 13235 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ()); 13236 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string.c_str (), 13237 ops, tempflag, disabled, from_tty); 13238 c->excep_string = excep_string; 13239 create_excep_cond_exprs (c.get (), ex_kind); 13240 if (!cond_string.empty ()) 13241 set_breakpoint_condition (c.get (), cond_string.c_str (), from_tty); 13242 install_breakpoint (0, std::move (c), 1); 13243} 13244 13245/* Implement the "catch exception" command. */ 13246 13247static void 13248catch_ada_exception_command (const char *arg_entry, int from_tty, 13249 struct cmd_list_element *command) 13250{ 13251 const char *arg = arg_entry; 13252 struct gdbarch *gdbarch = get_current_arch (); 13253 int tempflag; 13254 enum ada_exception_catchpoint_kind ex_kind; 13255 std::string excep_string; 13256 std::string cond_string; 13257 13258 tempflag = get_cmd_context (command) == CATCH_TEMPORARY; 13259 13260 if (!arg) 13261 arg = ""; 13262 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string, 13263 &cond_string); 13264 create_ada_exception_catchpoint (gdbarch, ex_kind, 13265 excep_string, cond_string, 13266 tempflag, 1 /* enabled */, 13267 from_tty); 13268} 13269 13270/* Implement the "catch handlers" command. */ 13271 13272static void 13273catch_ada_handlers_command (const char *arg_entry, int from_tty, 13274 struct cmd_list_element *command) 13275{ 13276 const char *arg = arg_entry; 13277 struct gdbarch *gdbarch = get_current_arch (); 13278 int tempflag; 13279 enum ada_exception_catchpoint_kind ex_kind; 13280 std::string excep_string; 13281 std::string cond_string; 13282 13283 tempflag = get_cmd_context (command) == CATCH_TEMPORARY; 13284 13285 if (!arg) 13286 arg = ""; 13287 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string, 13288 &cond_string); 13289 create_ada_exception_catchpoint (gdbarch, ex_kind, 13290 excep_string, cond_string, 13291 tempflag, 1 /* enabled */, 13292 from_tty); 13293} 13294 13295/* Split the arguments specified in a "catch assert" command. 13296 13297 ARGS contains the command's arguments (or the empty string if 13298 no arguments were passed). 13299 13300 If ARGS contains a condition, set COND_STRING to that condition 13301 (the memory needs to be deallocated after use). */ 13302 13303static void 13304catch_ada_assert_command_split (const char *args, std::string &cond_string) 13305{ 13306 args = skip_spaces (args); 13307 13308 /* Check whether a condition was provided. */ 13309 if (startswith (args, "if") 13310 && (isspace (args[2]) || args[2] == '\0')) 13311 { 13312 args += 2; 13313 args = skip_spaces (args); 13314 if (args[0] == '\0') 13315 error (_("condition missing after `if' keyword")); 13316 cond_string.assign (args); 13317 } 13318 13319 /* Otherwise, there should be no other argument at the end of 13320 the command. */ 13321 else if (args[0] != '\0') 13322 error (_("Junk at end of arguments.")); 13323} 13324 13325/* Implement the "catch assert" command. */ 13326 13327static void 13328catch_assert_command (const char *arg_entry, int from_tty, 13329 struct cmd_list_element *command) 13330{ 13331 const char *arg = arg_entry; 13332 struct gdbarch *gdbarch = get_current_arch (); 13333 int tempflag; 13334 std::string cond_string; 13335 13336 tempflag = get_cmd_context (command) == CATCH_TEMPORARY; 13337 13338 if (!arg) 13339 arg = ""; 13340 catch_ada_assert_command_split (arg, cond_string); 13341 create_ada_exception_catchpoint (gdbarch, ada_catch_assert, 13342 "", cond_string, 13343 tempflag, 1 /* enabled */, 13344 from_tty); 13345} 13346 13347/* Return non-zero if the symbol SYM is an Ada exception object. */ 13348 13349static int 13350ada_is_exception_sym (struct symbol *sym) 13351{ 13352 const char *type_name = TYPE_NAME (SYMBOL_TYPE (sym)); 13353 13354 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF 13355 && SYMBOL_CLASS (sym) != LOC_BLOCK 13356 && SYMBOL_CLASS (sym) != LOC_CONST 13357 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED 13358 && type_name != NULL && strcmp (type_name, "exception") == 0); 13359} 13360 13361/* Given a global symbol SYM, return non-zero iff SYM is a non-standard 13362 Ada exception object. This matches all exceptions except the ones 13363 defined by the Ada language. */ 13364 13365static int 13366ada_is_non_standard_exception_sym (struct symbol *sym) 13367{ 13368 int i; 13369 13370 if (!ada_is_exception_sym (sym)) 13371 return 0; 13372 13373 for (i = 0; i < ARRAY_SIZE (standard_exc); i++) 13374 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0) 13375 return 0; /* A standard exception. */ 13376 13377 /* Numeric_Error is also a standard exception, so exclude it. 13378 See the STANDARD_EXC description for more details as to why 13379 this exception is not listed in that array. */ 13380 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0) 13381 return 0; 13382 13383 return 1; 13384} 13385 13386/* A helper function for std::sort, comparing two struct ada_exc_info 13387 objects. 13388 13389 The comparison is determined first by exception name, and then 13390 by exception address. */ 13391 13392bool 13393ada_exc_info::operator< (const ada_exc_info &other) const 13394{ 13395 int result; 13396 13397 result = strcmp (name, other.name); 13398 if (result < 0) 13399 return true; 13400 if (result == 0 && addr < other.addr) 13401 return true; 13402 return false; 13403} 13404 13405bool 13406ada_exc_info::operator== (const ada_exc_info &other) const 13407{ 13408 return addr == other.addr && strcmp (name, other.name) == 0; 13409} 13410 13411/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison 13412 routine, but keeping the first SKIP elements untouched. 13413 13414 All duplicates are also removed. */ 13415 13416static void 13417sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions, 13418 int skip) 13419{ 13420 std::sort (exceptions->begin () + skip, exceptions->end ()); 13421 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()), 13422 exceptions->end ()); 13423} 13424 13425/* Add all exceptions defined by the Ada standard whose name match 13426 a regular expression. 13427 13428 If PREG is not NULL, then this regexp_t object is used to 13429 perform the symbol name matching. Otherwise, no name-based 13430 filtering is performed. 13431 13432 EXCEPTIONS is a vector of exceptions to which matching exceptions 13433 gets pushed. */ 13434 13435static void 13436ada_add_standard_exceptions (compiled_regex *preg, 13437 std::vector<ada_exc_info> *exceptions) 13438{ 13439 int i; 13440 13441 for (i = 0; i < ARRAY_SIZE (standard_exc); i++) 13442 { 13443 if (preg == NULL 13444 || preg->exec (standard_exc[i], 0, NULL, 0) == 0) 13445 { 13446 struct bound_minimal_symbol msymbol 13447 = ada_lookup_simple_minsym (standard_exc[i]); 13448 13449 if (msymbol.minsym != NULL) 13450 { 13451 struct ada_exc_info info 13452 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)}; 13453 13454 exceptions->push_back (info); 13455 } 13456 } 13457 } 13458} 13459 13460/* Add all Ada exceptions defined locally and accessible from the given 13461 FRAME. 13462 13463 If PREG is not NULL, then this regexp_t object is used to 13464 perform the symbol name matching. Otherwise, no name-based 13465 filtering is performed. 13466 13467 EXCEPTIONS is a vector of exceptions to which matching exceptions 13468 gets pushed. */ 13469 13470static void 13471ada_add_exceptions_from_frame (compiled_regex *preg, 13472 struct frame_info *frame, 13473 std::vector<ada_exc_info> *exceptions) 13474{ 13475 const struct block *block = get_frame_block (frame, 0); 13476 13477 while (block != 0) 13478 { 13479 struct block_iterator iter; 13480 struct symbol *sym; 13481 13482 ALL_BLOCK_SYMBOLS (block, iter, sym) 13483 { 13484 switch (SYMBOL_CLASS (sym)) 13485 { 13486 case LOC_TYPEDEF: 13487 case LOC_BLOCK: 13488 case LOC_CONST: 13489 break; 13490 default: 13491 if (ada_is_exception_sym (sym)) 13492 { 13493 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym), 13494 SYMBOL_VALUE_ADDRESS (sym)}; 13495 13496 exceptions->push_back (info); 13497 } 13498 } 13499 } 13500 if (BLOCK_FUNCTION (block) != NULL) 13501 break; 13502 block = BLOCK_SUPERBLOCK (block); 13503 } 13504} 13505 13506/* Return true if NAME matches PREG or if PREG is NULL. */ 13507 13508static bool 13509name_matches_regex (const char *name, compiled_regex *preg) 13510{ 13511 return (preg == NULL 13512 || preg->exec (ada_decode (name), 0, NULL, 0) == 0); 13513} 13514 13515/* Add all exceptions defined globally whose name name match 13516 a regular expression, excluding standard exceptions. 13517 13518 The reason we exclude standard exceptions is that they need 13519 to be handled separately: Standard exceptions are defined inside 13520 a runtime unit which is normally not compiled with debugging info, 13521 and thus usually do not show up in our symbol search. However, 13522 if the unit was in fact built with debugging info, we need to 13523 exclude them because they would duplicate the entry we found 13524 during the special loop that specifically searches for those 13525 standard exceptions. 13526 13527 If PREG is not NULL, then this regexp_t object is used to 13528 perform the symbol name matching. Otherwise, no name-based 13529 filtering is performed. 13530 13531 EXCEPTIONS is a vector of exceptions to which matching exceptions 13532 gets pushed. */ 13533 13534static void 13535ada_add_global_exceptions (compiled_regex *preg, 13536 std::vector<ada_exc_info> *exceptions) 13537{ 13538 /* In Ada, the symbol "search name" is a linkage name, whereas the 13539 regular expression used to do the matching refers to the natural 13540 name. So match against the decoded name. */ 13541 expand_symtabs_matching (NULL, 13542 lookup_name_info::match_any (), 13543 [&] (const char *search_name) 13544 { 13545 const char *decoded = ada_decode (search_name); 13546 return name_matches_regex (decoded, preg); 13547 }, 13548 NULL, 13549 VARIABLES_DOMAIN); 13550 13551 for (objfile *objfile : current_program_space->objfiles ()) 13552 { 13553 for (compunit_symtab *s : objfile->compunits ()) 13554 { 13555 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s); 13556 int i; 13557 13558 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++) 13559 { 13560 struct block *b = BLOCKVECTOR_BLOCK (bv, i); 13561 struct block_iterator iter; 13562 struct symbol *sym; 13563 13564 ALL_BLOCK_SYMBOLS (b, iter, sym) 13565 if (ada_is_non_standard_exception_sym (sym) 13566 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg)) 13567 { 13568 struct ada_exc_info info 13569 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)}; 13570 13571 exceptions->push_back (info); 13572 } 13573 } 13574 } 13575 } 13576} 13577 13578/* Implements ada_exceptions_list with the regular expression passed 13579 as a regex_t, rather than a string. 13580 13581 If not NULL, PREG is used to filter out exceptions whose names 13582 do not match. Otherwise, all exceptions are listed. */ 13583 13584static std::vector<ada_exc_info> 13585ada_exceptions_list_1 (compiled_regex *preg) 13586{ 13587 std::vector<ada_exc_info> result; 13588 int prev_len; 13589 13590 /* First, list the known standard exceptions. These exceptions 13591 need to be handled separately, as they are usually defined in 13592 runtime units that have been compiled without debugging info. */ 13593 13594 ada_add_standard_exceptions (preg, &result); 13595 13596 /* Next, find all exceptions whose scope is local and accessible 13597 from the currently selected frame. */ 13598 13599 if (has_stack_frames ()) 13600 { 13601 prev_len = result.size (); 13602 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL), 13603 &result); 13604 if (result.size () > prev_len) 13605 sort_remove_dups_ada_exceptions_list (&result, prev_len); 13606 } 13607 13608 /* Add all exceptions whose scope is global. */ 13609 13610 prev_len = result.size (); 13611 ada_add_global_exceptions (preg, &result); 13612 if (result.size () > prev_len) 13613 sort_remove_dups_ada_exceptions_list (&result, prev_len); 13614 13615 return result; 13616} 13617 13618/* Return a vector of ada_exc_info. 13619 13620 If REGEXP is NULL, all exceptions are included in the result. 13621 Otherwise, it should contain a valid regular expression, 13622 and only the exceptions whose names match that regular expression 13623 are included in the result. 13624 13625 The exceptions are sorted in the following order: 13626 - Standard exceptions (defined by the Ada language), in 13627 alphabetical order; 13628 - Exceptions only visible from the current frame, in 13629 alphabetical order; 13630 - Exceptions whose scope is global, in alphabetical order. */ 13631 13632std::vector<ada_exc_info> 13633ada_exceptions_list (const char *regexp) 13634{ 13635 if (regexp == NULL) 13636 return ada_exceptions_list_1 (NULL); 13637 13638 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression")); 13639 return ada_exceptions_list_1 (®); 13640} 13641 13642/* Implement the "info exceptions" command. */ 13643 13644static void 13645info_exceptions_command (const char *regexp, int from_tty) 13646{ 13647 struct gdbarch *gdbarch = get_current_arch (); 13648 13649 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp); 13650 13651 if (regexp != NULL) 13652 printf_filtered 13653 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp); 13654 else 13655 printf_filtered (_("All defined Ada exceptions:\n")); 13656 13657 for (const ada_exc_info &info : exceptions) 13658 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr)); 13659} 13660 13661 /* Operators */ 13662/* Information about operators given special treatment in functions 13663 below. */ 13664/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */ 13665 13666#define ADA_OPERATORS \ 13667 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \ 13668 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \ 13669 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \ 13670 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \ 13671 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \ 13672 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \ 13673 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \ 13674 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \ 13675 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \ 13676 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \ 13677 OP_DEFN (OP_ATR_POS, 1, 2, 0) \ 13678 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \ 13679 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \ 13680 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \ 13681 OP_DEFN (UNOP_QUAL, 3, 1, 0) \ 13682 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \ 13683 OP_DEFN (OP_OTHERS, 1, 1, 0) \ 13684 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \ 13685 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0) 13686 13687static void 13688ada_operator_length (const struct expression *exp, int pc, int *oplenp, 13689 int *argsp) 13690{ 13691 switch (exp->elts[pc - 1].opcode) 13692 { 13693 default: 13694 operator_length_standard (exp, pc, oplenp, argsp); 13695 break; 13696 13697#define OP_DEFN(op, len, args, binop) \ 13698 case op: *oplenp = len; *argsp = args; break; 13699 ADA_OPERATORS; 13700#undef OP_DEFN 13701 13702 case OP_AGGREGATE: 13703 *oplenp = 3; 13704 *argsp = longest_to_int (exp->elts[pc - 2].longconst); 13705 break; 13706 13707 case OP_CHOICES: 13708 *oplenp = 3; 13709 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1; 13710 break; 13711 } 13712} 13713 13714/* Implementation of the exp_descriptor method operator_check. */ 13715 13716static int 13717ada_operator_check (struct expression *exp, int pos, 13718 int (*objfile_func) (struct objfile *objfile, void *data), 13719 void *data) 13720{ 13721 const union exp_element *const elts = exp->elts; 13722 struct type *type = NULL; 13723 13724 switch (elts[pos].opcode) 13725 { 13726 case UNOP_IN_RANGE: 13727 case UNOP_QUAL: 13728 type = elts[pos + 1].type; 13729 break; 13730 13731 default: 13732 return operator_check_standard (exp, pos, objfile_func, data); 13733 } 13734 13735 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */ 13736 13737 if (type && TYPE_OBJFILE (type) 13738 && (*objfile_func) (TYPE_OBJFILE (type), data)) 13739 return 1; 13740 13741 return 0; 13742} 13743 13744static const char * 13745ada_op_name (enum exp_opcode opcode) 13746{ 13747 switch (opcode) 13748 { 13749 default: 13750 return op_name_standard (opcode); 13751 13752#define OP_DEFN(op, len, args, binop) case op: return #op; 13753 ADA_OPERATORS; 13754#undef OP_DEFN 13755 13756 case OP_AGGREGATE: 13757 return "OP_AGGREGATE"; 13758 case OP_CHOICES: 13759 return "OP_CHOICES"; 13760 case OP_NAME: 13761 return "OP_NAME"; 13762 } 13763} 13764 13765/* As for operator_length, but assumes PC is pointing at the first 13766 element of the operator, and gives meaningful results only for the 13767 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */ 13768 13769static void 13770ada_forward_operator_length (struct expression *exp, int pc, 13771 int *oplenp, int *argsp) 13772{ 13773 switch (exp->elts[pc].opcode) 13774 { 13775 default: 13776 *oplenp = *argsp = 0; 13777 break; 13778 13779#define OP_DEFN(op, len, args, binop) \ 13780 case op: *oplenp = len; *argsp = args; break; 13781 ADA_OPERATORS; 13782#undef OP_DEFN 13783 13784 case OP_AGGREGATE: 13785 *oplenp = 3; 13786 *argsp = longest_to_int (exp->elts[pc + 1].longconst); 13787 break; 13788 13789 case OP_CHOICES: 13790 *oplenp = 3; 13791 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1; 13792 break; 13793 13794 case OP_STRING: 13795 case OP_NAME: 13796 { 13797 int len = longest_to_int (exp->elts[pc + 1].longconst); 13798 13799 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1); 13800 *argsp = 0; 13801 break; 13802 } 13803 } 13804} 13805 13806static int 13807ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt) 13808{ 13809 enum exp_opcode op = exp->elts[elt].opcode; 13810 int oplen, nargs; 13811 int pc = elt; 13812 int i; 13813 13814 ada_forward_operator_length (exp, elt, &oplen, &nargs); 13815 13816 switch (op) 13817 { 13818 /* Ada attributes ('Foo). */ 13819 case OP_ATR_FIRST: 13820 case OP_ATR_LAST: 13821 case OP_ATR_LENGTH: 13822 case OP_ATR_IMAGE: 13823 case OP_ATR_MAX: 13824 case OP_ATR_MIN: 13825 case OP_ATR_MODULUS: 13826 case OP_ATR_POS: 13827 case OP_ATR_SIZE: 13828 case OP_ATR_TAG: 13829 case OP_ATR_VAL: 13830 break; 13831 13832 case UNOP_IN_RANGE: 13833 case UNOP_QUAL: 13834 /* XXX: gdb_sprint_host_address, type_sprint */ 13835 fprintf_filtered (stream, _("Type @")); 13836 gdb_print_host_address (exp->elts[pc + 1].type, stream); 13837 fprintf_filtered (stream, " ("); 13838 type_print (exp->elts[pc + 1].type, NULL, stream, 0); 13839 fprintf_filtered (stream, ")"); 13840 break; 13841 case BINOP_IN_BOUNDS: 13842 fprintf_filtered (stream, " (%d)", 13843 longest_to_int (exp->elts[pc + 2].longconst)); 13844 break; 13845 case TERNOP_IN_RANGE: 13846 break; 13847 13848 case OP_AGGREGATE: 13849 case OP_OTHERS: 13850 case OP_DISCRETE_RANGE: 13851 case OP_POSITIONAL: 13852 case OP_CHOICES: 13853 break; 13854 13855 case OP_NAME: 13856 case OP_STRING: 13857 { 13858 char *name = &exp->elts[elt + 2].string; 13859 int len = longest_to_int (exp->elts[elt + 1].longconst); 13860 13861 fprintf_filtered (stream, "Text: `%.*s'", len, name); 13862 break; 13863 } 13864 13865 default: 13866 return dump_subexp_body_standard (exp, stream, elt); 13867 } 13868 13869 elt += oplen; 13870 for (i = 0; i < nargs; i += 1) 13871 elt = dump_subexp (exp, stream, elt); 13872 13873 return elt; 13874} 13875 13876/* The Ada extension of print_subexp (q.v.). */ 13877 13878static void 13879ada_print_subexp (struct expression *exp, int *pos, 13880 struct ui_file *stream, enum precedence prec) 13881{ 13882 int oplen, nargs, i; 13883 int pc = *pos; 13884 enum exp_opcode op = exp->elts[pc].opcode; 13885 13886 ada_forward_operator_length (exp, pc, &oplen, &nargs); 13887 13888 *pos += oplen; 13889 switch (op) 13890 { 13891 default: 13892 *pos -= oplen; 13893 print_subexp_standard (exp, pos, stream, prec); 13894 return; 13895 13896 case OP_VAR_VALUE: 13897 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream); 13898 return; 13899 13900 case BINOP_IN_BOUNDS: 13901 /* XXX: sprint_subexp */ 13902 print_subexp (exp, pos, stream, PREC_SUFFIX); 13903 fputs_filtered (" in ", stream); 13904 print_subexp (exp, pos, stream, PREC_SUFFIX); 13905 fputs_filtered ("'range", stream); 13906 if (exp->elts[pc + 1].longconst > 1) 13907 fprintf_filtered (stream, "(%ld)", 13908 (long) exp->elts[pc + 1].longconst); 13909 return; 13910 13911 case TERNOP_IN_RANGE: 13912 if (prec >= PREC_EQUAL) 13913 fputs_filtered ("(", stream); 13914 /* XXX: sprint_subexp */ 13915 print_subexp (exp, pos, stream, PREC_SUFFIX); 13916 fputs_filtered (" in ", stream); 13917 print_subexp (exp, pos, stream, PREC_EQUAL); 13918 fputs_filtered (" .. ", stream); 13919 print_subexp (exp, pos, stream, PREC_EQUAL); 13920 if (prec >= PREC_EQUAL) 13921 fputs_filtered (")", stream); 13922 return; 13923 13924 case OP_ATR_FIRST: 13925 case OP_ATR_LAST: 13926 case OP_ATR_LENGTH: 13927 case OP_ATR_IMAGE: 13928 case OP_ATR_MAX: 13929 case OP_ATR_MIN: 13930 case OP_ATR_MODULUS: 13931 case OP_ATR_POS: 13932 case OP_ATR_SIZE: 13933 case OP_ATR_TAG: 13934 case OP_ATR_VAL: 13935 if (exp->elts[*pos].opcode == OP_TYPE) 13936 { 13937 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID) 13938 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0, 13939 &type_print_raw_options); 13940 *pos += 3; 13941 } 13942 else 13943 print_subexp (exp, pos, stream, PREC_SUFFIX); 13944 fprintf_filtered (stream, "'%s", ada_attribute_name (op)); 13945 if (nargs > 1) 13946 { 13947 int tem; 13948 13949 for (tem = 1; tem < nargs; tem += 1) 13950 { 13951 fputs_filtered ((tem == 1) ? " (" : ", ", stream); 13952 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA); 13953 } 13954 fputs_filtered (")", stream); 13955 } 13956 return; 13957 13958 case UNOP_QUAL: 13959 type_print (exp->elts[pc + 1].type, "", stream, 0); 13960 fputs_filtered ("'(", stream); 13961 print_subexp (exp, pos, stream, PREC_PREFIX); 13962 fputs_filtered (")", stream); 13963 return; 13964 13965 case UNOP_IN_RANGE: 13966 /* XXX: sprint_subexp */ 13967 print_subexp (exp, pos, stream, PREC_SUFFIX); 13968 fputs_filtered (" in ", stream); 13969 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0, 13970 &type_print_raw_options); 13971 return; 13972 13973 case OP_DISCRETE_RANGE: 13974 print_subexp (exp, pos, stream, PREC_SUFFIX); 13975 fputs_filtered ("..", stream); 13976 print_subexp (exp, pos, stream, PREC_SUFFIX); 13977 return; 13978 13979 case OP_OTHERS: 13980 fputs_filtered ("others => ", stream); 13981 print_subexp (exp, pos, stream, PREC_SUFFIX); 13982 return; 13983 13984 case OP_CHOICES: 13985 for (i = 0; i < nargs-1; i += 1) 13986 { 13987 if (i > 0) 13988 fputs_filtered ("|", stream); 13989 print_subexp (exp, pos, stream, PREC_SUFFIX); 13990 } 13991 fputs_filtered (" => ", stream); 13992 print_subexp (exp, pos, stream, PREC_SUFFIX); 13993 return; 13994 13995 case OP_POSITIONAL: 13996 print_subexp (exp, pos, stream, PREC_SUFFIX); 13997 return; 13998 13999 case OP_AGGREGATE: 14000 fputs_filtered ("(", stream); 14001 for (i = 0; i < nargs; i += 1) 14002 { 14003 if (i > 0) 14004 fputs_filtered (", ", stream); 14005 print_subexp (exp, pos, stream, PREC_SUFFIX); 14006 } 14007 fputs_filtered (")", stream); 14008 return; 14009 } 14010} 14011 14012/* Table mapping opcodes into strings for printing operators 14013 and precedences of the operators. */ 14014 14015static const struct op_print ada_op_print_tab[] = { 14016 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1}, 14017 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0}, 14018 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0}, 14019 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0}, 14020 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0}, 14021 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0}, 14022 {"=", BINOP_EQUAL, PREC_EQUAL, 0}, 14023 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0}, 14024 {"<=", BINOP_LEQ, PREC_ORDER, 0}, 14025 {">=", BINOP_GEQ, PREC_ORDER, 0}, 14026 {">", BINOP_GTR, PREC_ORDER, 0}, 14027 {"<", BINOP_LESS, PREC_ORDER, 0}, 14028 {">>", BINOP_RSH, PREC_SHIFT, 0}, 14029 {"<<", BINOP_LSH, PREC_SHIFT, 0}, 14030 {"+", BINOP_ADD, PREC_ADD, 0}, 14031 {"-", BINOP_SUB, PREC_ADD, 0}, 14032 {"&", BINOP_CONCAT, PREC_ADD, 0}, 14033 {"*", BINOP_MUL, PREC_MUL, 0}, 14034 {"/", BINOP_DIV, PREC_MUL, 0}, 14035 {"rem", BINOP_REM, PREC_MUL, 0}, 14036 {"mod", BINOP_MOD, PREC_MUL, 0}, 14037 {"**", BINOP_EXP, PREC_REPEAT, 0}, 14038 {"@", BINOP_REPEAT, PREC_REPEAT, 0}, 14039 {"-", UNOP_NEG, PREC_PREFIX, 0}, 14040 {"+", UNOP_PLUS, PREC_PREFIX, 0}, 14041 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0}, 14042 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0}, 14043 {"abs ", UNOP_ABS, PREC_PREFIX, 0}, 14044 {".all", UNOP_IND, PREC_SUFFIX, 1}, 14045 {"'access", UNOP_ADDR, PREC_SUFFIX, 1}, 14046 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1}, 14047 {NULL, OP_NULL, PREC_SUFFIX, 0} 14048}; 14049 14050enum ada_primitive_types { 14051 ada_primitive_type_int, 14052 ada_primitive_type_long, 14053 ada_primitive_type_short, 14054 ada_primitive_type_char, 14055 ada_primitive_type_float, 14056 ada_primitive_type_double, 14057 ada_primitive_type_void, 14058 ada_primitive_type_long_long, 14059 ada_primitive_type_long_double, 14060 ada_primitive_type_natural, 14061 ada_primitive_type_positive, 14062 ada_primitive_type_system_address, 14063 ada_primitive_type_storage_offset, 14064 nr_ada_primitive_types 14065}; 14066 14067static void 14068ada_language_arch_info (struct gdbarch *gdbarch, 14069 struct language_arch_info *lai) 14070{ 14071 const struct builtin_type *builtin = builtin_type (gdbarch); 14072 14073 lai->primitive_type_vector 14074 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1, 14075 struct type *); 14076 14077 lai->primitive_type_vector [ada_primitive_type_int] 14078 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 14079 0, "integer"); 14080 lai->primitive_type_vector [ada_primitive_type_long] 14081 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 14082 0, "long_integer"); 14083 lai->primitive_type_vector [ada_primitive_type_short] 14084 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 14085 0, "short_integer"); 14086 lai->string_char_type 14087 = lai->primitive_type_vector [ada_primitive_type_char] 14088 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character"); 14089 lai->primitive_type_vector [ada_primitive_type_float] 14090 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), 14091 "float", gdbarch_float_format (gdbarch)); 14092 lai->primitive_type_vector [ada_primitive_type_double] 14093 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch), 14094 "long_float", gdbarch_double_format (gdbarch)); 14095 lai->primitive_type_vector [ada_primitive_type_long_long] 14096 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 14097 0, "long_long_integer"); 14098 lai->primitive_type_vector [ada_primitive_type_long_double] 14099 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch), 14100 "long_long_float", gdbarch_long_double_format (gdbarch)); 14101 lai->primitive_type_vector [ada_primitive_type_natural] 14102 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 14103 0, "natural"); 14104 lai->primitive_type_vector [ada_primitive_type_positive] 14105 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 14106 0, "positive"); 14107 lai->primitive_type_vector [ada_primitive_type_void] 14108 = builtin->builtin_void; 14109 14110 lai->primitive_type_vector [ada_primitive_type_system_address] 14111 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, 14112 "void")); 14113 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address]) 14114 = "system__address"; 14115 14116 /* Create the equivalent of the System.Storage_Elements.Storage_Offset 14117 type. This is a signed integral type whose size is the same as 14118 the size of addresses. */ 14119 { 14120 unsigned int addr_length = TYPE_LENGTH 14121 (lai->primitive_type_vector [ada_primitive_type_system_address]); 14122 14123 lai->primitive_type_vector [ada_primitive_type_storage_offset] 14124 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0, 14125 "storage_offset"); 14126 } 14127 14128 lai->bool_type_symbol = NULL; 14129 lai->bool_type_default = builtin->builtin_bool; 14130} 14131 14132 /* Language vector */ 14133 14134/* Not really used, but needed in the ada_language_defn. */ 14135 14136static void 14137emit_char (int c, struct type *type, struct ui_file *stream, int quoter) 14138{ 14139 ada_emit_char (c, type, stream, quoter, 1); 14140} 14141 14142static int 14143parse (struct parser_state *ps) 14144{ 14145 warnings_issued = 0; 14146 return ada_parse (ps); 14147} 14148 14149static const struct exp_descriptor ada_exp_descriptor = { 14150 ada_print_subexp, 14151 ada_operator_length, 14152 ada_operator_check, 14153 ada_op_name, 14154 ada_dump_subexp_body, 14155 ada_evaluate_subexp 14156}; 14157 14158/* symbol_name_matcher_ftype adapter for wild_match. */ 14159 14160static bool 14161do_wild_match (const char *symbol_search_name, 14162 const lookup_name_info &lookup_name, 14163 completion_match_result *comp_match_res) 14164{ 14165 return wild_match (symbol_search_name, ada_lookup_name (lookup_name)); 14166} 14167 14168/* symbol_name_matcher_ftype adapter for full_match. */ 14169 14170static bool 14171do_full_match (const char *symbol_search_name, 14172 const lookup_name_info &lookup_name, 14173 completion_match_result *comp_match_res) 14174{ 14175 return full_match (symbol_search_name, ada_lookup_name (lookup_name)); 14176} 14177 14178/* symbol_name_matcher_ftype for exact (verbatim) matches. */ 14179 14180static bool 14181do_exact_match (const char *symbol_search_name, 14182 const lookup_name_info &lookup_name, 14183 completion_match_result *comp_match_res) 14184{ 14185 return strcmp (symbol_search_name, ada_lookup_name (lookup_name)) == 0; 14186} 14187 14188/* Build the Ada lookup name for LOOKUP_NAME. */ 14189 14190ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name) 14191{ 14192 const std::string &user_name = lookup_name.name (); 14193 14194 if (user_name[0] == '<') 14195 { 14196 if (user_name.back () == '>') 14197 m_encoded_name = user_name.substr (1, user_name.size () - 2); 14198 else 14199 m_encoded_name = user_name.substr (1, user_name.size () - 1); 14200 m_encoded_p = true; 14201 m_verbatim_p = true; 14202 m_wild_match_p = false; 14203 m_standard_p = false; 14204 } 14205 else 14206 { 14207 m_verbatim_p = false; 14208 14209 m_encoded_p = user_name.find ("__") != std::string::npos; 14210 14211 if (!m_encoded_p) 14212 { 14213 const char *folded = ada_fold_name (user_name.c_str ()); 14214 const char *encoded = ada_encode_1 (folded, false); 14215 if (encoded != NULL) 14216 m_encoded_name = encoded; 14217 else 14218 m_encoded_name = user_name; 14219 } 14220 else 14221 m_encoded_name = user_name; 14222 14223 /* Handle the 'package Standard' special case. See description 14224 of m_standard_p. */ 14225 if (startswith (m_encoded_name.c_str (), "standard__")) 14226 { 14227 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1); 14228 m_standard_p = true; 14229 } 14230 else 14231 m_standard_p = false; 14232 14233 /* If the name contains a ".", then the user is entering a fully 14234 qualified entity name, and the match must not be done in wild 14235 mode. Similarly, if the user wants to complete what looks 14236 like an encoded name, the match must not be done in wild 14237 mode. Also, in the standard__ special case always do 14238 non-wild matching. */ 14239 m_wild_match_p 14240 = (lookup_name.match_type () != symbol_name_match_type::FULL 14241 && !m_encoded_p 14242 && !m_standard_p 14243 && user_name.find ('.') == std::string::npos); 14244 } 14245} 14246 14247/* symbol_name_matcher_ftype method for Ada. This only handles 14248 completion mode. */ 14249 14250static bool 14251ada_symbol_name_matches (const char *symbol_search_name, 14252 const lookup_name_info &lookup_name, 14253 completion_match_result *comp_match_res) 14254{ 14255 return lookup_name.ada ().matches (symbol_search_name, 14256 lookup_name.match_type (), 14257 comp_match_res); 14258} 14259 14260/* A name matcher that matches the symbol name exactly, with 14261 strcmp. */ 14262 14263static bool 14264literal_symbol_name_matcher (const char *symbol_search_name, 14265 const lookup_name_info &lookup_name, 14266 completion_match_result *comp_match_res) 14267{ 14268 const std::string &name = lookup_name.name (); 14269 14270 int cmp = (lookup_name.completion_mode () 14271 ? strncmp (symbol_search_name, name.c_str (), name.size ()) 14272 : strcmp (symbol_search_name, name.c_str ())); 14273 if (cmp == 0) 14274 { 14275 if (comp_match_res != NULL) 14276 comp_match_res->set_match (symbol_search_name); 14277 return true; 14278 } 14279 else 14280 return false; 14281} 14282 14283/* Implement the "la_get_symbol_name_matcher" language_defn method for 14284 Ada. */ 14285 14286static symbol_name_matcher_ftype * 14287ada_get_symbol_name_matcher (const lookup_name_info &lookup_name) 14288{ 14289 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME) 14290 return literal_symbol_name_matcher; 14291 14292 if (lookup_name.completion_mode ()) 14293 return ada_symbol_name_matches; 14294 else 14295 { 14296 if (lookup_name.ada ().wild_match_p ()) 14297 return do_wild_match; 14298 else if (lookup_name.ada ().verbatim_p ()) 14299 return do_exact_match; 14300 else 14301 return do_full_match; 14302 } 14303} 14304 14305/* Implement the "la_read_var_value" language_defn method for Ada. */ 14306 14307static struct value * 14308ada_read_var_value (struct symbol *var, const struct block *var_block, 14309 struct frame_info *frame) 14310{ 14311 const struct block *frame_block = NULL; 14312 struct symbol *renaming_sym = NULL; 14313 14314 /* The only case where default_read_var_value is not sufficient 14315 is when VAR is a renaming... */ 14316 if (frame) 14317 frame_block = get_frame_block (frame, NULL); 14318 if (frame_block) 14319 renaming_sym = ada_find_renaming_symbol (var, frame_block); 14320 if (renaming_sym != NULL) 14321 return ada_read_renaming_var_value (renaming_sym, frame_block); 14322 14323 /* This is a typical case where we expect the default_read_var_value 14324 function to work. */ 14325 return default_read_var_value (var, var_block, frame); 14326} 14327 14328static const char *ada_extensions[] = 14329{ 14330 ".adb", ".ads", ".a", ".ada", ".dg", NULL 14331}; 14332 14333extern const struct language_defn ada_language_defn = { 14334 "ada", /* Language name */ 14335 "Ada", 14336 language_ada, 14337 range_check_off, 14338 case_sensitive_on, /* Yes, Ada is case-insensitive, but 14339 that's not quite what this means. */ 14340 array_row_major, 14341 macro_expansion_no, 14342 ada_extensions, 14343 &ada_exp_descriptor, 14344 parse, 14345 resolve, 14346 ada_printchar, /* Print a character constant */ 14347 ada_printstr, /* Function to print string constant */ 14348 emit_char, /* Function to print single char (not used) */ 14349 ada_print_type, /* Print a type using appropriate syntax */ 14350 ada_print_typedef, /* Print a typedef using appropriate syntax */ 14351 ada_val_print, /* Print a value using appropriate syntax */ 14352 ada_value_print, /* Print a top-level value */ 14353 ada_read_var_value, /* la_read_var_value */ 14354 NULL, /* Language specific skip_trampoline */ 14355 NULL, /* name_of_this */ 14356 true, /* la_store_sym_names_in_linkage_form_p */ 14357 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */ 14358 basic_lookup_transparent_type, /* lookup_transparent_type */ 14359 ada_la_decode, /* Language specific symbol demangler */ 14360 ada_sniff_from_mangled_name, 14361 NULL, /* Language specific 14362 class_name_from_physname */ 14363 ada_op_print_tab, /* expression operators for printing */ 14364 0, /* c-style arrays */ 14365 1, /* String lower bound */ 14366 ada_get_gdb_completer_word_break_characters, 14367 ada_collect_symbol_completion_matches, 14368 ada_language_arch_info, 14369 ada_print_array_index, 14370 default_pass_by_reference, 14371 c_get_string, 14372 ada_watch_location_expression, 14373 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */ 14374 ada_iterate_over_symbols, 14375 default_search_name_hash, 14376 &ada_varobj_ops, 14377 NULL, 14378 NULL, 14379 LANG_MAGIC 14380}; 14381 14382/* Command-list for the "set/show ada" prefix command. */ 14383static struct cmd_list_element *set_ada_list; 14384static struct cmd_list_element *show_ada_list; 14385 14386/* Implement the "set ada" prefix command. */ 14387 14388static void 14389set_ada_command (const char *arg, int from_tty) 14390{ 14391 printf_unfiltered (_(\ 14392"\"set ada\" must be followed by the name of a setting.\n")); 14393 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout); 14394} 14395 14396/* Implement the "show ada" prefix command. */ 14397 14398static void 14399show_ada_command (const char *args, int from_tty) 14400{ 14401 cmd_show_list (show_ada_list, from_tty, ""); 14402} 14403 14404static void 14405initialize_ada_catchpoint_ops (void) 14406{ 14407 struct breakpoint_ops *ops; 14408 14409 initialize_breakpoint_ops (); 14410 14411 ops = &catch_exception_breakpoint_ops; 14412 *ops = bkpt_breakpoint_ops; 14413 ops->allocate_location = allocate_location_catch_exception; 14414 ops->re_set = re_set_catch_exception; 14415 ops->check_status = check_status_catch_exception; 14416 ops->print_it = print_it_catch_exception; 14417 ops->print_one = print_one_catch_exception; 14418 ops->print_mention = print_mention_catch_exception; 14419 ops->print_recreate = print_recreate_catch_exception; 14420 14421 ops = &catch_exception_unhandled_breakpoint_ops; 14422 *ops = bkpt_breakpoint_ops; 14423 ops->allocate_location = allocate_location_catch_exception_unhandled; 14424 ops->re_set = re_set_catch_exception_unhandled; 14425 ops->check_status = check_status_catch_exception_unhandled; 14426 ops->print_it = print_it_catch_exception_unhandled; 14427 ops->print_one = print_one_catch_exception_unhandled; 14428 ops->print_mention = print_mention_catch_exception_unhandled; 14429 ops->print_recreate = print_recreate_catch_exception_unhandled; 14430 14431 ops = &catch_assert_breakpoint_ops; 14432 *ops = bkpt_breakpoint_ops; 14433 ops->allocate_location = allocate_location_catch_assert; 14434 ops->re_set = re_set_catch_assert; 14435 ops->check_status = check_status_catch_assert; 14436 ops->print_it = print_it_catch_assert; 14437 ops->print_one = print_one_catch_assert; 14438 ops->print_mention = print_mention_catch_assert; 14439 ops->print_recreate = print_recreate_catch_assert; 14440 14441 ops = &catch_handlers_breakpoint_ops; 14442 *ops = bkpt_breakpoint_ops; 14443 ops->allocate_location = allocate_location_catch_handlers; 14444 ops->re_set = re_set_catch_handlers; 14445 ops->check_status = check_status_catch_handlers; 14446 ops->print_it = print_it_catch_handlers; 14447 ops->print_one = print_one_catch_handlers; 14448 ops->print_mention = print_mention_catch_handlers; 14449 ops->print_recreate = print_recreate_catch_handlers; 14450} 14451 14452/* This module's 'new_objfile' observer. */ 14453 14454static void 14455ada_new_objfile_observer (struct objfile *objfile) 14456{ 14457 ada_clear_symbol_cache (); 14458} 14459 14460/* This module's 'free_objfile' observer. */ 14461 14462static void 14463ada_free_objfile_observer (struct objfile *objfile) 14464{ 14465 ada_clear_symbol_cache (); 14466} 14467 14468void 14469_initialize_ada_language (void) 14470{ 14471 initialize_ada_catchpoint_ops (); 14472 14473 add_prefix_cmd ("ada", no_class, set_ada_command, 14474 _("Prefix command for changing Ada-specific settings"), 14475 &set_ada_list, "set ada ", 0, &setlist); 14476 14477 add_prefix_cmd ("ada", no_class, show_ada_command, 14478 _("Generic command for showing Ada-specific settings."), 14479 &show_ada_list, "show ada ", 0, &showlist); 14480 14481 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure, 14482 &trust_pad_over_xvs, _("\ 14483Enable or disable an optimization trusting PAD types over XVS types"), _("\ 14484Show whether an optimization trusting PAD types over XVS types is activated"), 14485 _("\ 14486This is related to the encoding used by the GNAT compiler. The debugger\n\ 14487should normally trust the contents of PAD types, but certain older versions\n\ 14488of GNAT have a bug that sometimes causes the information in the PAD type\n\ 14489to be incorrect. Turning this setting \"off\" allows the debugger to\n\ 14490work around this bug. It is always safe to turn this option \"off\", but\n\ 14491this incurs a slight performance penalty, so it is recommended to NOT change\n\ 14492this option to \"off\" unless necessary."), 14493 NULL, NULL, &set_ada_list, &show_ada_list); 14494 14495 add_setshow_boolean_cmd ("print-signatures", class_vars, 14496 &print_signatures, _("\ 14497Enable or disable the output of formal and return types for functions in the \ 14498overloads selection menu"), _("\ 14499Show whether the output of formal and return types for functions in the \ 14500overloads selection menu is activated"), 14501 NULL, NULL, NULL, &set_ada_list, &show_ada_list); 14502 14503 add_catch_command ("exception", _("\ 14504Catch Ada exceptions, when raised.\n\ 14505Usage: catch exception [ ARG ]\n\ 14506\n\ 14507Without any argument, stop when any Ada exception is raised.\n\ 14508If ARG is \"unhandled\" (without the quotes), only stop when the exception\n\ 14509being raised does not have a handler (and will therefore lead to the task's\n\ 14510termination).\n\ 14511Otherwise, the catchpoint only stops when the name of the exception being\n\ 14512raised is the same as ARG."), 14513 catch_ada_exception_command, 14514 NULL, 14515 CATCH_PERMANENT, 14516 CATCH_TEMPORARY); 14517 14518 add_catch_command ("handlers", _("\ 14519Catch Ada exceptions, when handled.\n\ 14520With an argument, catch only exceptions with the given name."), 14521 catch_ada_handlers_command, 14522 NULL, 14523 CATCH_PERMANENT, 14524 CATCH_TEMPORARY); 14525 add_catch_command ("assert", _("\ 14526Catch failed Ada assertions, when raised.\n\ 14527With an argument, catch only exceptions with the given name."), 14528 catch_assert_command, 14529 NULL, 14530 CATCH_PERMANENT, 14531 CATCH_TEMPORARY); 14532 14533 varsize_limit = 65536; 14534 add_setshow_uinteger_cmd ("varsize-limit", class_support, 14535 &varsize_limit, _("\ 14536Set the maximum number of bytes allowed in a variable-size object."), _("\ 14537Show the maximum number of bytes allowed in a variable-size object."), _("\ 14538Attempts to access an object whose size is not a compile-time constant\n\ 14539and exceeds this limit will cause an error."), 14540 NULL, NULL, &setlist, &showlist); 14541 14542 add_info ("exceptions", info_exceptions_command, 14543 _("\ 14544List all Ada exception names.\n\ 14545If a regular expression is passed as an argument, only those matching\n\ 14546the regular expression are listed.")); 14547 14548 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd, 14549 _("Set Ada maintenance-related variables."), 14550 &maint_set_ada_cmdlist, "maintenance set ada ", 14551 0/*allow-unknown*/, &maintenance_set_cmdlist); 14552 14553 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd, 14554 _("Show Ada maintenance-related variables"), 14555 &maint_show_ada_cmdlist, "maintenance show ada ", 14556 0/*allow-unknown*/, &maintenance_show_cmdlist); 14557 14558 add_setshow_boolean_cmd 14559 ("ignore-descriptive-types", class_maintenance, 14560 &ada_ignore_descriptive_types_p, 14561 _("Set whether descriptive types generated by GNAT should be ignored."), 14562 _("Show whether descriptive types generated by GNAT should be ignored."), 14563 _("\ 14564When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\ 14565DWARF attribute."), 14566 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist); 14567 14568 decoded_names_store = htab_create_alloc (256, htab_hash_string, streq_hash, 14569 NULL, xcalloc, xfree); 14570 14571 /* The ada-lang observers. */ 14572 gdb::observers::new_objfile.attach (ada_new_objfile_observer); 14573 gdb::observers::free_objfile.attach (ada_free_objfile_observer); 14574 gdb::observers::inferior_exit.attach (ada_inferior_exit); 14575 14576 /* Setup various context-specific data. */ 14577 ada_inferior_data 14578 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup); 14579 ada_pspace_data_handle 14580 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup); 14581} 14582