ada-lang.c revision 1.5
1/* Ada language support routines for GDB, the GNU debugger. 2 3 Copyright (C) 1992-2015 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 "observer.h" 52#include "vec.h" 53#include "stack.h" 54#include "gdb_vecs.h" 55#include "typeprint.h" 56 57#include "psymtab.h" 58#include "value.h" 59#include "mi/mi-common.h" 60#include "arch-utils.h" 61#include "cli/cli-utils.h" 62 63/* Define whether or not the C operator '/' truncates towards zero for 64 differently signed operands (truncation direction is undefined in C). 65 Copied from valarith.c. */ 66 67#ifndef TRUNCATION_TOWARDS_ZERO 68#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2) 69#endif 70 71static struct type *desc_base_type (struct type *); 72 73static struct type *desc_bounds_type (struct type *); 74 75static struct value *desc_bounds (struct value *); 76 77static int fat_pntr_bounds_bitpos (struct type *); 78 79static int fat_pntr_bounds_bitsize (struct type *); 80 81static struct type *desc_data_target_type (struct type *); 82 83static struct value *desc_data (struct value *); 84 85static int fat_pntr_data_bitpos (struct type *); 86 87static int fat_pntr_data_bitsize (struct type *); 88 89static struct value *desc_one_bound (struct value *, int, int); 90 91static int desc_bound_bitpos (struct type *, int, int); 92 93static int desc_bound_bitsize (struct type *, int, int); 94 95static struct type *desc_index_type (struct type *, int); 96 97static int desc_arity (struct type *); 98 99static int ada_type_match (struct type *, struct type *, int); 100 101static int ada_args_match (struct symbol *, struct value **, int); 102 103static int full_match (const char *, const char *); 104 105static struct value *make_array_descriptor (struct type *, struct value *); 106 107static void ada_add_block_symbols (struct obstack *, 108 const struct block *, const char *, 109 domain_enum, struct objfile *, int); 110 111static int is_nonfunction (struct ada_symbol_info *, int); 112 113static void add_defn_to_vec (struct obstack *, struct symbol *, 114 const struct block *); 115 116static int num_defns_collected (struct obstack *); 117 118static struct ada_symbol_info *defns_collected (struct obstack *, int); 119 120static struct value *resolve_subexp (struct expression **, int *, int, 121 struct type *); 122 123static void replace_operator_with_call (struct expression **, int, int, int, 124 struct symbol *, const struct block *); 125 126static int possible_user_operator_p (enum exp_opcode, struct value **); 127 128static char *ada_op_name (enum exp_opcode); 129 130static const char *ada_decoded_op_name (enum exp_opcode); 131 132static int numeric_type_p (struct type *); 133 134static int integer_type_p (struct type *); 135 136static int scalar_type_p (struct type *); 137 138static int discrete_type_p (struct type *); 139 140static enum ada_renaming_category parse_old_style_renaming (struct type *, 141 const char **, 142 int *, 143 const char **); 144 145static struct symbol *find_old_style_renaming_symbol (const char *, 146 const struct block *); 147 148static struct type *ada_lookup_struct_elt_type (struct type *, char *, 149 int, int, int *); 150 151static struct value *evaluate_subexp_type (struct expression *, int *); 152 153static struct type *ada_find_parallel_type_with_name (struct type *, 154 const char *); 155 156static int is_dynamic_field (struct type *, int); 157 158static struct type *to_fixed_variant_branch_type (struct type *, 159 const gdb_byte *, 160 CORE_ADDR, struct value *); 161 162static struct type *to_fixed_array_type (struct type *, struct value *, int); 163 164static struct type *to_fixed_range_type (struct type *, struct value *); 165 166static struct type *to_static_fixed_type (struct type *); 167static struct type *static_unwrap_type (struct type *type); 168 169static struct value *unwrap_value (struct value *); 170 171static struct type *constrained_packed_array_type (struct type *, long *); 172 173static struct type *decode_constrained_packed_array_type (struct type *); 174 175static long decode_packed_array_bitsize (struct type *); 176 177static struct value *decode_constrained_packed_array (struct value *); 178 179static int ada_is_packed_array_type (struct type *); 180 181static int ada_is_unconstrained_packed_array_type (struct type *); 182 183static struct value *value_subscript_packed (struct value *, int, 184 struct value **); 185 186static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int); 187 188static struct value *coerce_unspec_val_to_type (struct value *, 189 struct type *); 190 191static struct value *get_var_value (char *, char *); 192 193static int lesseq_defined_than (struct symbol *, struct symbol *); 194 195static int equiv_types (struct type *, struct type *); 196 197static int is_name_suffix (const char *); 198 199static int advance_wild_match (const char **, const char *, int); 200 201static int wild_match (const char *, const char *); 202 203static struct value *ada_coerce_ref (struct value *); 204 205static LONGEST pos_atr (struct value *); 206 207static struct value *value_pos_atr (struct type *, struct value *); 208 209static struct value *value_val_atr (struct type *, struct value *); 210 211static struct symbol *standard_lookup (const char *, const struct block *, 212 domain_enum); 213 214static struct value *ada_search_struct_field (char *, struct value *, int, 215 struct type *); 216 217static struct value *ada_value_primitive_field (struct value *, int, int, 218 struct type *); 219 220static int find_struct_field (const char *, struct type *, int, 221 struct type **, int *, int *, int *, int *); 222 223static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR, 224 struct value *); 225 226static int ada_resolve_function (struct ada_symbol_info *, 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 269 270/* The result of a symbol lookup to be stored in our symbol cache. */ 271 272struct cache_entry 273{ 274 /* The name used to perform the lookup. */ 275 const char *name; 276 /* The namespace used during the lookup. */ 277 domain_enum domain; 278 /* The symbol returned by the lookup, or NULL if no matching symbol 279 was found. */ 280 struct symbol *sym; 281 /* The block where the symbol was found, or NULL if no matching 282 symbol was found. */ 283 const struct block *block; 284 /* A pointer to the next entry with the same hash. */ 285 struct cache_entry *next; 286}; 287 288/* The Ada symbol cache, used to store the result of Ada-mode symbol 289 lookups in the course of executing the user's commands. 290 291 The cache is implemented using a simple, fixed-sized hash. 292 The size is fixed on the grounds that there are not likely to be 293 all that many symbols looked up during any given session, regardless 294 of the size of the symbol table. If we decide to go to a resizable 295 table, let's just use the stuff from libiberty instead. */ 296 297#define HASH_SIZE 1009 298 299struct ada_symbol_cache 300{ 301 /* An obstack used to store the entries in our cache. */ 302 struct obstack cache_space; 303 304 /* The root of the hash table used to implement our symbol cache. */ 305 struct cache_entry *root[HASH_SIZE]; 306}; 307 308static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache); 309 310/* Maximum-sized dynamic type. */ 311static unsigned int varsize_limit; 312 313/* FIXME: brobecker/2003-09-17: No longer a const because it is 314 returned by a function that does not return a const char *. */ 315static char *ada_completer_word_break_characters = 316#ifdef VMS 317 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-"; 318#else 319 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-"; 320#endif 321 322/* The name of the symbol to use to get the name of the main subprogram. */ 323static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[] 324 = "__gnat_ada_main_program_name"; 325 326/* Limit on the number of warnings to raise per expression evaluation. */ 327static int warning_limit = 2; 328 329/* Number of warning messages issued; reset to 0 by cleanups after 330 expression evaluation. */ 331static int warnings_issued = 0; 332 333static const char *known_runtime_file_name_patterns[] = { 334 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL 335}; 336 337static const char *known_auxiliary_function_name_patterns[] = { 338 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL 339}; 340 341/* Space for allocating results of ada_lookup_symbol_list. */ 342static struct obstack symbol_list_obstack; 343 344/* Maintenance-related settings for this module. */ 345 346static struct cmd_list_element *maint_set_ada_cmdlist; 347static struct cmd_list_element *maint_show_ada_cmdlist; 348 349/* Implement the "maintenance set ada" (prefix) command. */ 350 351static void 352maint_set_ada_cmd (char *args, int from_tty) 353{ 354 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands, 355 gdb_stdout); 356} 357 358/* Implement the "maintenance show ada" (prefix) command. */ 359 360static void 361maint_show_ada_cmd (char *args, int from_tty) 362{ 363 cmd_show_list (maint_show_ada_cmdlist, from_tty, ""); 364} 365 366/* The "maintenance ada set/show ignore-descriptive-type" value. */ 367 368static int ada_ignore_descriptive_types_p = 0; 369 370 /* Inferior-specific data. */ 371 372/* Per-inferior data for this module. */ 373 374struct ada_inferior_data 375{ 376 /* The ada__tags__type_specific_data type, which is used when decoding 377 tagged types. With older versions of GNAT, this type was directly 378 accessible through a component ("tsd") in the object tag. But this 379 is no longer the case, so we cache it for each inferior. */ 380 struct type *tsd_type; 381 382 /* The exception_support_info data. This data is used to determine 383 how to implement support for Ada exception catchpoints in a given 384 inferior. */ 385 const struct exception_support_info *exception_info; 386}; 387 388/* Our key to this module's inferior data. */ 389static const struct inferior_data *ada_inferior_data; 390 391/* A cleanup routine for our inferior data. */ 392static void 393ada_inferior_data_cleanup (struct inferior *inf, void *arg) 394{ 395 struct ada_inferior_data *data; 396 397 data = inferior_data (inf, ada_inferior_data); 398 if (data != NULL) 399 xfree (data); 400} 401 402/* Return our inferior data for the given inferior (INF). 403 404 This function always returns a valid pointer to an allocated 405 ada_inferior_data structure. If INF's inferior data has not 406 been previously set, this functions creates a new one with all 407 fields set to zero, sets INF's inferior to it, and then returns 408 a pointer to that newly allocated ada_inferior_data. */ 409 410static struct ada_inferior_data * 411get_ada_inferior_data (struct inferior *inf) 412{ 413 struct ada_inferior_data *data; 414 415 data = inferior_data (inf, ada_inferior_data); 416 if (data == NULL) 417 { 418 data = XCNEW (struct ada_inferior_data); 419 set_inferior_data (inf, ada_inferior_data, data); 420 } 421 422 return data; 423} 424 425/* Perform all necessary cleanups regarding our module's inferior data 426 that is required after the inferior INF just exited. */ 427 428static void 429ada_inferior_exit (struct inferior *inf) 430{ 431 ada_inferior_data_cleanup (inf, NULL); 432 set_inferior_data (inf, ada_inferior_data, NULL); 433} 434 435 436 /* program-space-specific data. */ 437 438/* This module's per-program-space data. */ 439struct ada_pspace_data 440{ 441 /* The Ada symbol cache. */ 442 struct ada_symbol_cache *sym_cache; 443}; 444 445/* Key to our per-program-space data. */ 446static const struct program_space_data *ada_pspace_data_handle; 447 448/* Return this module's data for the given program space (PSPACE). 449 If not is found, add a zero'ed one now. 450 451 This function always returns a valid object. */ 452 453static struct ada_pspace_data * 454get_ada_pspace_data (struct program_space *pspace) 455{ 456 struct ada_pspace_data *data; 457 458 data = 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 = 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 The result is good until the next call. */ 544 545static char * 546add_angle_brackets (const char *str) 547{ 548 static char *result = NULL; 549 550 xfree (result); 551 result = xstrprintf ("<%s>", str); 552 return result; 553} 554 555static char * 556ada_get_gdb_completer_word_break_characters (void) 557{ 558 return ada_completer_word_break_characters; 559} 560 561/* Print an array element index using the Ada syntax. */ 562 563static void 564ada_print_array_index (struct value *index_value, struct ui_file *stream, 565 const struct value_print_options *options) 566{ 567 LA_VALUE_PRINT (index_value, stream, options); 568 fprintf_filtered (stream, " => "); 569} 570 571/* Assuming VECT points to an array of *SIZE objects of size 572 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects, 573 updating *SIZE as necessary and returning the (new) array. */ 574 575void * 576grow_vect (void *vect, size_t *size, size_t min_size, int element_size) 577{ 578 if (*size < min_size) 579 { 580 *size *= 2; 581 if (*size < min_size) 582 *size = min_size; 583 vect = xrealloc (vect, *size * element_size); 584 } 585 return vect; 586} 587 588/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing 589 suffix of FIELD_NAME beginning "___". */ 590 591static int 592field_name_match (const char *field_name, const char *target) 593{ 594 int len = strlen (target); 595 596 return 597 (strncmp (field_name, target, len) == 0 598 && (field_name[len] == '\0' 599 || (startswith (field_name + len, "___") 600 && strcmp (field_name + strlen (field_name) - 6, 601 "___XVN") != 0))); 602} 603 604 605/* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to 606 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME, 607 and return its index. This function also handles fields whose name 608 have ___ suffixes because the compiler sometimes alters their name 609 by adding such a suffix to represent fields with certain constraints. 610 If the field could not be found, return a negative number if 611 MAYBE_MISSING is set. Otherwise raise an error. */ 612 613int 614ada_get_field_index (const struct type *type, const char *field_name, 615 int maybe_missing) 616{ 617 int fieldno; 618 struct type *struct_type = check_typedef ((struct type *) type); 619 620 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++) 621 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name)) 622 return fieldno; 623 624 if (!maybe_missing) 625 error (_("Unable to find field %s in struct %s. Aborting"), 626 field_name, TYPE_NAME (struct_type)); 627 628 return -1; 629} 630 631/* The length of the prefix of NAME prior to any "___" suffix. */ 632 633int 634ada_name_prefix_len (const char *name) 635{ 636 if (name == NULL) 637 return 0; 638 else 639 { 640 const char *p = strstr (name, "___"); 641 642 if (p == NULL) 643 return strlen (name); 644 else 645 return p - name; 646 } 647} 648 649/* Return non-zero if SUFFIX is a suffix of STR. 650 Return zero if STR is null. */ 651 652static int 653is_suffix (const char *str, const char *suffix) 654{ 655 int len1, len2; 656 657 if (str == NULL) 658 return 0; 659 len1 = strlen (str); 660 len2 = strlen (suffix); 661 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0); 662} 663 664/* The contents of value VAL, treated as a value of type TYPE. The 665 result is an lval in memory if VAL is. */ 666 667static struct value * 668coerce_unspec_val_to_type (struct value *val, struct type *type) 669{ 670 type = ada_check_typedef (type); 671 if (value_type (val) == type) 672 return val; 673 else 674 { 675 struct value *result; 676 677 /* Make sure that the object size is not unreasonable before 678 trying to allocate some memory for it. */ 679 ada_ensure_varsize_limit (type); 680 681 if (value_lazy (val) 682 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val))) 683 result = allocate_value_lazy (type); 684 else 685 { 686 result = allocate_value (type); 687 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type)); 688 } 689 set_value_component_location (result, val); 690 set_value_bitsize (result, value_bitsize (val)); 691 set_value_bitpos (result, value_bitpos (val)); 692 set_value_address (result, value_address (val)); 693 return result; 694 } 695} 696 697static const gdb_byte * 698cond_offset_host (const gdb_byte *valaddr, long offset) 699{ 700 if (valaddr == NULL) 701 return NULL; 702 else 703 return valaddr + offset; 704} 705 706static CORE_ADDR 707cond_offset_target (CORE_ADDR address, long offset) 708{ 709 if (address == 0) 710 return 0; 711 else 712 return address + offset; 713} 714 715/* Issue a warning (as for the definition of warning in utils.c, but 716 with exactly one argument rather than ...), unless the limit on the 717 number of warnings has passed during the evaluation of the current 718 expression. */ 719 720/* FIXME: cagney/2004-10-10: This function is mimicking the behavior 721 provided by "complaint". */ 722static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2); 723 724static void 725lim_warning (const char *format, ...) 726{ 727 va_list args; 728 729 va_start (args, format); 730 warnings_issued += 1; 731 if (warnings_issued <= warning_limit) 732 vwarning (format, args); 733 734 va_end (args); 735} 736 737/* Issue an error if the size of an object of type T is unreasonable, 738 i.e. if it would be a bad idea to allocate a value of this type in 739 GDB. */ 740 741void 742ada_ensure_varsize_limit (const struct type *type) 743{ 744 if (TYPE_LENGTH (type) > varsize_limit) 745 error (_("object size is larger than varsize-limit")); 746} 747 748/* Maximum value of a SIZE-byte signed integer type. */ 749static LONGEST 750max_of_size (int size) 751{ 752 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2); 753 754 return top_bit | (top_bit - 1); 755} 756 757/* Minimum value of a SIZE-byte signed integer type. */ 758static LONGEST 759min_of_size (int size) 760{ 761 return -max_of_size (size) - 1; 762} 763 764/* Maximum value of a SIZE-byte unsigned integer type. */ 765static ULONGEST 766umax_of_size (int size) 767{ 768 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1); 769 770 return top_bit | (top_bit - 1); 771} 772 773/* Maximum value of integral type T, as a signed quantity. */ 774static LONGEST 775max_of_type (struct type *t) 776{ 777 if (TYPE_UNSIGNED (t)) 778 return (LONGEST) umax_of_size (TYPE_LENGTH (t)); 779 else 780 return max_of_size (TYPE_LENGTH (t)); 781} 782 783/* Minimum value of integral type T, as a signed quantity. */ 784static LONGEST 785min_of_type (struct type *t) 786{ 787 if (TYPE_UNSIGNED (t)) 788 return 0; 789 else 790 return min_of_size (TYPE_LENGTH (t)); 791} 792 793/* The largest value in the domain of TYPE, a discrete type, as an integer. */ 794LONGEST 795ada_discrete_type_high_bound (struct type *type) 796{ 797 type = resolve_dynamic_type (type, NULL, 0); 798 switch (TYPE_CODE (type)) 799 { 800 case TYPE_CODE_RANGE: 801 return TYPE_HIGH_BOUND (type); 802 case TYPE_CODE_ENUM: 803 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1); 804 case TYPE_CODE_BOOL: 805 return 1; 806 case TYPE_CODE_CHAR: 807 case TYPE_CODE_INT: 808 return max_of_type (type); 809 default: 810 error (_("Unexpected type in ada_discrete_type_high_bound.")); 811 } 812} 813 814/* The smallest value in the domain of TYPE, a discrete type, as an integer. */ 815LONGEST 816ada_discrete_type_low_bound (struct type *type) 817{ 818 type = resolve_dynamic_type (type, NULL, 0); 819 switch (TYPE_CODE (type)) 820 { 821 case TYPE_CODE_RANGE: 822 return TYPE_LOW_BOUND (type); 823 case TYPE_CODE_ENUM: 824 return TYPE_FIELD_ENUMVAL (type, 0); 825 case TYPE_CODE_BOOL: 826 return 0; 827 case TYPE_CODE_CHAR: 828 case TYPE_CODE_INT: 829 return min_of_type (type); 830 default: 831 error (_("Unexpected type in ada_discrete_type_low_bound.")); 832 } 833} 834 835/* The identity on non-range types. For range types, the underlying 836 non-range scalar type. */ 837 838static struct type * 839get_base_type (struct type *type) 840{ 841 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE) 842 { 843 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL) 844 return type; 845 type = TYPE_TARGET_TYPE (type); 846 } 847 return type; 848} 849 850/* Return a decoded version of the given VALUE. This means returning 851 a value whose type is obtained by applying all the GNAT-specific 852 encondings, making the resulting type a static but standard description 853 of the initial type. */ 854 855struct value * 856ada_get_decoded_value (struct value *value) 857{ 858 struct type *type = ada_check_typedef (value_type (value)); 859 860 if (ada_is_array_descriptor_type (type) 861 || (ada_is_constrained_packed_array_type (type) 862 && TYPE_CODE (type) != TYPE_CODE_PTR)) 863 { 864 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */ 865 value = ada_coerce_to_simple_array_ptr (value); 866 else 867 value = ada_coerce_to_simple_array (value); 868 } 869 else 870 value = ada_to_fixed_value (value); 871 872 return value; 873} 874 875/* Same as ada_get_decoded_value, but with the given TYPE. 876 Because there is no associated actual value for this type, 877 the resulting type might be a best-effort approximation in 878 the case of dynamic types. */ 879 880struct type * 881ada_get_decoded_type (struct type *type) 882{ 883 type = to_static_fixed_type (type); 884 if (ada_is_constrained_packed_array_type (type)) 885 type = ada_coerce_to_simple_array_type (type); 886 return type; 887} 888 889 890 891 /* Language Selection */ 892 893/* If the main program is in Ada, return language_ada, otherwise return LANG 894 (the main program is in Ada iif the adainit symbol is found). */ 895 896enum language 897ada_update_initial_language (enum language lang) 898{ 899 if (lookup_minimal_symbol ("adainit", (const char *) NULL, 900 (struct objfile *) NULL).minsym != NULL) 901 return language_ada; 902 903 return lang; 904} 905 906/* If the main procedure is written in Ada, then return its name. 907 The result is good until the next call. Return NULL if the main 908 procedure doesn't appear to be in Ada. */ 909 910char * 911ada_main_name (void) 912{ 913 struct bound_minimal_symbol msym; 914 static char *main_program_name = NULL; 915 916 /* For Ada, the name of the main procedure is stored in a specific 917 string constant, generated by the binder. Look for that symbol, 918 extract its address, and then read that string. If we didn't find 919 that string, then most probably the main procedure is not written 920 in Ada. */ 921 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL); 922 923 if (msym.minsym != NULL) 924 { 925 CORE_ADDR main_program_name_addr; 926 int err_code; 927 928 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym); 929 if (main_program_name_addr == 0) 930 error (_("Invalid address for Ada main program name.")); 931 932 xfree (main_program_name); 933 target_read_string (main_program_name_addr, &main_program_name, 934 1024, &err_code); 935 936 if (err_code != 0) 937 return NULL; 938 return main_program_name; 939 } 940 941 /* The main procedure doesn't seem to be in Ada. */ 942 return NULL; 943} 944 945 /* Symbols */ 946 947/* Table of Ada operators and their GNAT-encoded names. Last entry is pair 948 of NULLs. */ 949 950const struct ada_opname_map ada_opname_table[] = { 951 {"Oadd", "\"+\"", BINOP_ADD}, 952 {"Osubtract", "\"-\"", BINOP_SUB}, 953 {"Omultiply", "\"*\"", BINOP_MUL}, 954 {"Odivide", "\"/\"", BINOP_DIV}, 955 {"Omod", "\"mod\"", BINOP_MOD}, 956 {"Orem", "\"rem\"", BINOP_REM}, 957 {"Oexpon", "\"**\"", BINOP_EXP}, 958 {"Olt", "\"<\"", BINOP_LESS}, 959 {"Ole", "\"<=\"", BINOP_LEQ}, 960 {"Ogt", "\">\"", BINOP_GTR}, 961 {"Oge", "\">=\"", BINOP_GEQ}, 962 {"Oeq", "\"=\"", BINOP_EQUAL}, 963 {"One", "\"/=\"", BINOP_NOTEQUAL}, 964 {"Oand", "\"and\"", BINOP_BITWISE_AND}, 965 {"Oor", "\"or\"", BINOP_BITWISE_IOR}, 966 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR}, 967 {"Oconcat", "\"&\"", BINOP_CONCAT}, 968 {"Oabs", "\"abs\"", UNOP_ABS}, 969 {"Onot", "\"not\"", UNOP_LOGICAL_NOT}, 970 {"Oadd", "\"+\"", UNOP_PLUS}, 971 {"Osubtract", "\"-\"", UNOP_NEG}, 972 {NULL, NULL} 973}; 974 975/* The "encoded" form of DECODED, according to GNAT conventions. 976 The result is valid until the next call to ada_encode. */ 977 978char * 979ada_encode (const char *decoded) 980{ 981 static char *encoding_buffer = NULL; 982 static size_t encoding_buffer_size = 0; 983 const char *p; 984 int k; 985 986 if (decoded == NULL) 987 return NULL; 988 989 GROW_VECT (encoding_buffer, encoding_buffer_size, 990 2 * strlen (decoded) + 10); 991 992 k = 0; 993 for (p = decoded; *p != '\0'; p += 1) 994 { 995 if (*p == '.') 996 { 997 encoding_buffer[k] = encoding_buffer[k + 1] = '_'; 998 k += 2; 999 } 1000 else if (*p == '"') 1001 { 1002 const struct ada_opname_map *mapping; 1003 1004 for (mapping = ada_opname_table; 1005 mapping->encoded != NULL 1006 && !startswith (p, mapping->decoded); mapping += 1) 1007 ; 1008 if (mapping->encoded == NULL) 1009 error (_("invalid Ada operator name: %s"), p); 1010 strcpy (encoding_buffer + k, mapping->encoded); 1011 k += strlen (mapping->encoded); 1012 break; 1013 } 1014 else 1015 { 1016 encoding_buffer[k] = *p; 1017 k += 1; 1018 } 1019 } 1020 1021 encoding_buffer[k] = '\0'; 1022 return encoding_buffer; 1023} 1024 1025/* Return NAME folded to lower case, or, if surrounded by single 1026 quotes, unfolded, but with the quotes stripped away. Result good 1027 to next call. */ 1028 1029char * 1030ada_fold_name (const char *name) 1031{ 1032 static char *fold_buffer = NULL; 1033 static size_t fold_buffer_size = 0; 1034 1035 int len = strlen (name); 1036 GROW_VECT (fold_buffer, fold_buffer_size, len + 1); 1037 1038 if (name[0] == '\'') 1039 { 1040 strncpy (fold_buffer, name + 1, len - 2); 1041 fold_buffer[len - 2] = '\000'; 1042 } 1043 else 1044 { 1045 int i; 1046 1047 for (i = 0; i <= len; i += 1) 1048 fold_buffer[i] = tolower (name[i]); 1049 } 1050 1051 return fold_buffer; 1052} 1053 1054/* Return nonzero if C is either a digit or a lowercase alphabet character. */ 1055 1056static int 1057is_lower_alphanum (const char c) 1058{ 1059 return (isdigit (c) || (isalpha (c) && islower (c))); 1060} 1061 1062/* ENCODED is the linkage name of a symbol and LEN contains its length. 1063 This function saves in LEN the length of that same symbol name but 1064 without either of these suffixes: 1065 . .{DIGIT}+ 1066 . ${DIGIT}+ 1067 . ___{DIGIT}+ 1068 . __{DIGIT}+. 1069 1070 These are suffixes introduced by the compiler for entities such as 1071 nested subprogram for instance, in order to avoid name clashes. 1072 They do not serve any purpose for the debugger. */ 1073 1074static void 1075ada_remove_trailing_digits (const char *encoded, int *len) 1076{ 1077 if (*len > 1 && isdigit (encoded[*len - 1])) 1078 { 1079 int i = *len - 2; 1080 1081 while (i > 0 && isdigit (encoded[i])) 1082 i--; 1083 if (i >= 0 && encoded[i] == '.') 1084 *len = i; 1085 else if (i >= 0 && encoded[i] == '$') 1086 *len = i; 1087 else if (i >= 2 && startswith (encoded + i - 2, "___")) 1088 *len = i - 2; 1089 else if (i >= 1 && startswith (encoded + i - 1, "__")) 1090 *len = i - 1; 1091 } 1092} 1093 1094/* Remove the suffix introduced by the compiler for protected object 1095 subprograms. */ 1096 1097static void 1098ada_remove_po_subprogram_suffix (const char *encoded, int *len) 1099{ 1100 /* Remove trailing N. */ 1101 1102 /* Protected entry subprograms are broken into two 1103 separate subprograms: The first one is unprotected, and has 1104 a 'N' suffix; the second is the protected version, and has 1105 the 'P' suffix. The second calls the first one after handling 1106 the protection. Since the P subprograms are internally generated, 1107 we leave these names undecoded, giving the user a clue that this 1108 entity is internal. */ 1109 1110 if (*len > 1 1111 && encoded[*len - 1] == 'N' 1112 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2]))) 1113 *len = *len - 1; 1114} 1115 1116/* Remove trailing X[bn]* suffixes (indicating names in package bodies). */ 1117 1118static void 1119ada_remove_Xbn_suffix (const char *encoded, int *len) 1120{ 1121 int i = *len - 1; 1122 1123 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n')) 1124 i--; 1125 1126 if (encoded[i] != 'X') 1127 return; 1128 1129 if (i == 0) 1130 return; 1131 1132 if (isalnum (encoded[i-1])) 1133 *len = i; 1134} 1135 1136/* If ENCODED follows the GNAT entity encoding conventions, then return 1137 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is 1138 replaced by ENCODED. 1139 1140 The resulting string is valid until the next call of ada_decode. 1141 If the string is unchanged by decoding, the original string pointer 1142 is returned. */ 1143 1144const char * 1145ada_decode (const char *encoded) 1146{ 1147 int i, j; 1148 int len0; 1149 const char *p; 1150 char *decoded; 1151 int at_start_name; 1152 static char *decoding_buffer = NULL; 1153 static size_t decoding_buffer_size = 0; 1154 1155 /* The name of the Ada main procedure starts with "_ada_". 1156 This prefix is not part of the decoded name, so skip this part 1157 if we see this prefix. */ 1158 if (startswith (encoded, "_ada_")) 1159 encoded += 5; 1160 1161 /* If the name starts with '_', then it is not a properly encoded 1162 name, so do not attempt to decode it. Similarly, if the name 1163 starts with '<', the name should not be decoded. */ 1164 if (encoded[0] == '_' || encoded[0] == '<') 1165 goto Suppress; 1166 1167 len0 = strlen (encoded); 1168 1169 ada_remove_trailing_digits (encoded, &len0); 1170 ada_remove_po_subprogram_suffix (encoded, &len0); 1171 1172 /* Remove the ___X.* suffix if present. Do not forget to verify that 1173 the suffix is located before the current "end" of ENCODED. We want 1174 to avoid re-matching parts of ENCODED that have previously been 1175 marked as discarded (by decrementing LEN0). */ 1176 p = strstr (encoded, "___"); 1177 if (p != NULL && p - encoded < len0 - 3) 1178 { 1179 if (p[3] == 'X') 1180 len0 = p - encoded; 1181 else 1182 goto Suppress; 1183 } 1184 1185 /* Remove any trailing TKB suffix. It tells us that this symbol 1186 is for the body of a task, but that information does not actually 1187 appear in the decoded name. */ 1188 1189 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB")) 1190 len0 -= 3; 1191 1192 /* Remove any trailing TB suffix. The TB suffix is slightly different 1193 from the TKB suffix because it is used for non-anonymous task 1194 bodies. */ 1195 1196 if (len0 > 2 && startswith (encoded + len0 - 2, "TB")) 1197 len0 -= 2; 1198 1199 /* Remove trailing "B" suffixes. */ 1200 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */ 1201 1202 if (len0 > 1 && startswith (encoded + len0 - 1, "B")) 1203 len0 -= 1; 1204 1205 /* Make decoded big enough for possible expansion by operator name. */ 1206 1207 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1); 1208 decoded = decoding_buffer; 1209 1210 /* Remove trailing __{digit}+ or trailing ${digit}+. */ 1211 1212 if (len0 > 1 && isdigit (encoded[len0 - 1])) 1213 { 1214 i = len0 - 2; 1215 while ((i >= 0 && isdigit (encoded[i])) 1216 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1]))) 1217 i -= 1; 1218 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_') 1219 len0 = i - 1; 1220 else if (encoded[i] == '$') 1221 len0 = i; 1222 } 1223 1224 /* The first few characters that are not alphabetic are not part 1225 of any encoding we use, so we can copy them over verbatim. */ 1226 1227 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1) 1228 decoded[j] = encoded[i]; 1229 1230 at_start_name = 1; 1231 while (i < len0) 1232 { 1233 /* Is this a symbol function? */ 1234 if (at_start_name && encoded[i] == 'O') 1235 { 1236 int k; 1237 1238 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1) 1239 { 1240 int op_len = strlen (ada_opname_table[k].encoded); 1241 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1, 1242 op_len - 1) == 0) 1243 && !isalnum (encoded[i + op_len])) 1244 { 1245 strcpy (decoded + j, ada_opname_table[k].decoded); 1246 at_start_name = 0; 1247 i += op_len; 1248 j += strlen (ada_opname_table[k].decoded); 1249 break; 1250 } 1251 } 1252 if (ada_opname_table[k].encoded != NULL) 1253 continue; 1254 } 1255 at_start_name = 0; 1256 1257 /* Replace "TK__" with "__", which will eventually be translated 1258 into "." (just below). */ 1259 1260 if (i < len0 - 4 && startswith (encoded + i, "TK__")) 1261 i += 2; 1262 1263 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually 1264 be translated into "." (just below). These are internal names 1265 generated for anonymous blocks inside which our symbol is nested. */ 1266 1267 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_' 1268 && encoded [i+2] == 'B' && encoded [i+3] == '_' 1269 && isdigit (encoded [i+4])) 1270 { 1271 int k = i + 5; 1272 1273 while (k < len0 && isdigit (encoded[k])) 1274 k++; /* Skip any extra digit. */ 1275 1276 /* Double-check that the "__B_{DIGITS}+" sequence we found 1277 is indeed followed by "__". */ 1278 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_') 1279 i = k; 1280 } 1281 1282 /* Remove _E{DIGITS}+[sb] */ 1283 1284 /* Just as for protected object subprograms, there are 2 categories 1285 of subprograms created by the compiler for each entry. The first 1286 one implements the actual entry code, and has a suffix following 1287 the convention above; the second one implements the barrier and 1288 uses the same convention as above, except that the 'E' is replaced 1289 by a 'B'. 1290 1291 Just as above, we do not decode the name of barrier functions 1292 to give the user a clue that the code he is debugging has been 1293 internally generated. */ 1294 1295 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E' 1296 && isdigit (encoded[i+2])) 1297 { 1298 int k = i + 3; 1299 1300 while (k < len0 && isdigit (encoded[k])) 1301 k++; 1302 1303 if (k < len0 1304 && (encoded[k] == 'b' || encoded[k] == 's')) 1305 { 1306 k++; 1307 /* Just as an extra precaution, make sure that if this 1308 suffix is followed by anything else, it is a '_'. 1309 Otherwise, we matched this sequence by accident. */ 1310 if (k == len0 1311 || (k < len0 && encoded[k] == '_')) 1312 i = k; 1313 } 1314 } 1315 1316 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by 1317 the GNAT front-end in protected object subprograms. */ 1318 1319 if (i < len0 + 3 1320 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_') 1321 { 1322 /* Backtrack a bit up until we reach either the begining of 1323 the encoded name, or "__". Make sure that we only find 1324 digits or lowercase characters. */ 1325 const char *ptr = encoded + i - 1; 1326 1327 while (ptr >= encoded && is_lower_alphanum (ptr[0])) 1328 ptr--; 1329 if (ptr < encoded 1330 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_')) 1331 i++; 1332 } 1333 1334 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1])) 1335 { 1336 /* This is a X[bn]* sequence not separated from the previous 1337 part of the name with a non-alpha-numeric character (in other 1338 words, immediately following an alpha-numeric character), then 1339 verify that it is placed at the end of the encoded name. If 1340 not, then the encoding is not valid and we should abort the 1341 decoding. Otherwise, just skip it, it is used in body-nested 1342 package names. */ 1343 do 1344 i += 1; 1345 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n')); 1346 if (i < len0) 1347 goto Suppress; 1348 } 1349 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_') 1350 { 1351 /* Replace '__' by '.'. */ 1352 decoded[j] = '.'; 1353 at_start_name = 1; 1354 i += 2; 1355 j += 1; 1356 } 1357 else 1358 { 1359 /* It's a character part of the decoded name, so just copy it 1360 over. */ 1361 decoded[j] = encoded[i]; 1362 i += 1; 1363 j += 1; 1364 } 1365 } 1366 decoded[j] = '\000'; 1367 1368 /* Decoded names should never contain any uppercase character. 1369 Double-check this, and abort the decoding if we find one. */ 1370 1371 for (i = 0; decoded[i] != '\0'; i += 1) 1372 if (isupper (decoded[i]) || decoded[i] == ' ') 1373 goto Suppress; 1374 1375 if (strcmp (decoded, encoded) == 0) 1376 return encoded; 1377 else 1378 return decoded; 1379 1380Suppress: 1381 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3); 1382 decoded = decoding_buffer; 1383 if (encoded[0] == '<') 1384 strcpy (decoded, encoded); 1385 else 1386 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded); 1387 return decoded; 1388 1389} 1390 1391/* Table for keeping permanent unique copies of decoded names. Once 1392 allocated, names in this table are never released. While this is a 1393 storage leak, it should not be significant unless there are massive 1394 changes in the set of decoded names in successive versions of a 1395 symbol table loaded during a single session. */ 1396static struct htab *decoded_names_store; 1397 1398/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it 1399 in the language-specific part of GSYMBOL, if it has not been 1400 previously computed. Tries to save the decoded name in the same 1401 obstack as GSYMBOL, if possible, and otherwise on the heap (so that, 1402 in any case, the decoded symbol has a lifetime at least that of 1403 GSYMBOL). 1404 The GSYMBOL parameter is "mutable" in the C++ sense: logically 1405 const, but nevertheless modified to a semantically equivalent form 1406 when a decoded name is cached in it. */ 1407 1408const char * 1409ada_decode_symbol (const struct general_symbol_info *arg) 1410{ 1411 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg; 1412 const char **resultp = 1413 &gsymbol->language_specific.mangled_lang.demangled_name; 1414 1415 if (!gsymbol->ada_mangled) 1416 { 1417 const char *decoded = ada_decode (gsymbol->name); 1418 struct obstack *obstack = gsymbol->language_specific.obstack; 1419 1420 gsymbol->ada_mangled = 1; 1421 1422 if (obstack != NULL) 1423 *resultp = obstack_copy0 (obstack, decoded, strlen (decoded)); 1424 else 1425 { 1426 /* Sometimes, we can't find a corresponding objfile, in 1427 which case, we put the result on the heap. Since we only 1428 decode when needed, we hope this usually does not cause a 1429 significant memory leak (FIXME). */ 1430 1431 char **slot = (char **) htab_find_slot (decoded_names_store, 1432 decoded, INSERT); 1433 1434 if (*slot == NULL) 1435 *slot = xstrdup (decoded); 1436 *resultp = *slot; 1437 } 1438 } 1439 1440 return *resultp; 1441} 1442 1443static char * 1444ada_la_decode (const char *encoded, int options) 1445{ 1446 return xstrdup (ada_decode (encoded)); 1447} 1448 1449/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing 1450 suffixes that encode debugging information or leading _ada_ on 1451 SYM_NAME (see is_name_suffix commentary for the debugging 1452 information that is ignored). If WILD, then NAME need only match a 1453 suffix of SYM_NAME minus the same suffixes. Also returns 0 if 1454 either argument is NULL. */ 1455 1456static int 1457match_name (const char *sym_name, const char *name, int wild) 1458{ 1459 if (sym_name == NULL || name == NULL) 1460 return 0; 1461 else if (wild) 1462 return wild_match (sym_name, name) == 0; 1463 else 1464 { 1465 int len_name = strlen (name); 1466 1467 return (strncmp (sym_name, name, len_name) == 0 1468 && is_name_suffix (sym_name + len_name)) 1469 || (startswith (sym_name, "_ada_") 1470 && strncmp (sym_name + 5, name, len_name) == 0 1471 && is_name_suffix (sym_name + len_name + 5)); 1472 } 1473} 1474 1475 1476 /* Arrays */ 1477 1478/* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure 1479 generated by the GNAT compiler to describe the index type used 1480 for each dimension of an array, check whether it follows the latest 1481 known encoding. If not, fix it up to conform to the latest encoding. 1482 Otherwise, do nothing. This function also does nothing if 1483 INDEX_DESC_TYPE is NULL. 1484 1485 The GNAT encoding used to describle the array index type evolved a bit. 1486 Initially, the information would be provided through the name of each 1487 field of the structure type only, while the type of these fields was 1488 described as unspecified and irrelevant. The debugger was then expected 1489 to perform a global type lookup using the name of that field in order 1490 to get access to the full index type description. Because these global 1491 lookups can be very expensive, the encoding was later enhanced to make 1492 the global lookup unnecessary by defining the field type as being 1493 the full index type description. 1494 1495 The purpose of this routine is to allow us to support older versions 1496 of the compiler by detecting the use of the older encoding, and by 1497 fixing up the INDEX_DESC_TYPE to follow the new one (at this point, 1498 we essentially replace each field's meaningless type by the associated 1499 index subtype). */ 1500 1501void 1502ada_fixup_array_indexes_type (struct type *index_desc_type) 1503{ 1504 int i; 1505 1506 if (index_desc_type == NULL) 1507 return; 1508 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0); 1509 1510 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient 1511 to check one field only, no need to check them all). If not, return 1512 now. 1513 1514 If our INDEX_DESC_TYPE was generated using the older encoding, 1515 the field type should be a meaningless integer type whose name 1516 is not equal to the field name. */ 1517 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL 1518 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)), 1519 TYPE_FIELD_NAME (index_desc_type, 0)) == 0) 1520 return; 1521 1522 /* Fixup each field of INDEX_DESC_TYPE. */ 1523 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++) 1524 { 1525 const char *name = TYPE_FIELD_NAME (index_desc_type, i); 1526 struct type *raw_type = ada_check_typedef (ada_find_any_type (name)); 1527 1528 if (raw_type) 1529 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type; 1530 } 1531} 1532 1533/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */ 1534 1535static char *bound_name[] = { 1536 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3", 1537 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7" 1538}; 1539 1540/* Maximum number of array dimensions we are prepared to handle. */ 1541 1542#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *))) 1543 1544 1545/* The desc_* routines return primitive portions of array descriptors 1546 (fat pointers). */ 1547 1548/* The descriptor or array type, if any, indicated by TYPE; removes 1549 level of indirection, if needed. */ 1550 1551static struct type * 1552desc_base_type (struct type *type) 1553{ 1554 if (type == NULL) 1555 return NULL; 1556 type = ada_check_typedef (type); 1557 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 1558 type = ada_typedef_target_type (type); 1559 1560 if (type != NULL 1561 && (TYPE_CODE (type) == TYPE_CODE_PTR 1562 || TYPE_CODE (type) == TYPE_CODE_REF)) 1563 return ada_check_typedef (TYPE_TARGET_TYPE (type)); 1564 else 1565 return type; 1566} 1567 1568/* True iff TYPE indicates a "thin" array pointer type. */ 1569 1570static int 1571is_thin_pntr (struct type *type) 1572{ 1573 return 1574 is_suffix (ada_type_name (desc_base_type (type)), "___XUT") 1575 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE"); 1576} 1577 1578/* The descriptor type for thin pointer type TYPE. */ 1579 1580static struct type * 1581thin_descriptor_type (struct type *type) 1582{ 1583 struct type *base_type = desc_base_type (type); 1584 1585 if (base_type == NULL) 1586 return NULL; 1587 if (is_suffix (ada_type_name (base_type), "___XVE")) 1588 return base_type; 1589 else 1590 { 1591 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE"); 1592 1593 if (alt_type == NULL) 1594 return base_type; 1595 else 1596 return alt_type; 1597 } 1598} 1599 1600/* A pointer to the array data for thin-pointer value VAL. */ 1601 1602static struct value * 1603thin_data_pntr (struct value *val) 1604{ 1605 struct type *type = ada_check_typedef (value_type (val)); 1606 struct type *data_type = desc_data_target_type (thin_descriptor_type (type)); 1607 1608 data_type = lookup_pointer_type (data_type); 1609 1610 if (TYPE_CODE (type) == TYPE_CODE_PTR) 1611 return value_cast (data_type, value_copy (val)); 1612 else 1613 return value_from_longest (data_type, value_address (val)); 1614} 1615 1616/* True iff TYPE indicates a "thick" array pointer type. */ 1617 1618static int 1619is_thick_pntr (struct type *type) 1620{ 1621 type = desc_base_type (type); 1622 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT 1623 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL); 1624} 1625 1626/* If TYPE is the type of an array descriptor (fat or thin pointer) or a 1627 pointer to one, the type of its bounds data; otherwise, NULL. */ 1628 1629static struct type * 1630desc_bounds_type (struct type *type) 1631{ 1632 struct type *r; 1633 1634 type = desc_base_type (type); 1635 1636 if (type == NULL) 1637 return NULL; 1638 else if (is_thin_pntr (type)) 1639 { 1640 type = thin_descriptor_type (type); 1641 if (type == NULL) 1642 return NULL; 1643 r = lookup_struct_elt_type (type, "BOUNDS", 1); 1644 if (r != NULL) 1645 return ada_check_typedef (r); 1646 } 1647 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 1648 { 1649 r = lookup_struct_elt_type (type, "P_BOUNDS", 1); 1650 if (r != NULL) 1651 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r))); 1652 } 1653 return NULL; 1654} 1655 1656/* If ARR is an array descriptor (fat or thin pointer), or pointer to 1657 one, a pointer to its bounds data. Otherwise NULL. */ 1658 1659static struct value * 1660desc_bounds (struct value *arr) 1661{ 1662 struct type *type = ada_check_typedef (value_type (arr)); 1663 1664 if (is_thin_pntr (type)) 1665 { 1666 struct type *bounds_type = 1667 desc_bounds_type (thin_descriptor_type (type)); 1668 LONGEST addr; 1669 1670 if (bounds_type == NULL) 1671 error (_("Bad GNAT array descriptor")); 1672 1673 /* NOTE: The following calculation is not really kosher, but 1674 since desc_type is an XVE-encoded type (and shouldn't be), 1675 the correct calculation is a real pain. FIXME (and fix GCC). */ 1676 if (TYPE_CODE (type) == TYPE_CODE_PTR) 1677 addr = value_as_long (arr); 1678 else 1679 addr = value_address (arr); 1680 1681 return 1682 value_from_longest (lookup_pointer_type (bounds_type), 1683 addr - TYPE_LENGTH (bounds_type)); 1684 } 1685 1686 else if (is_thick_pntr (type)) 1687 { 1688 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL, 1689 _("Bad GNAT array descriptor")); 1690 struct type *p_bounds_type = value_type (p_bounds); 1691 1692 if (p_bounds_type 1693 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR) 1694 { 1695 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type); 1696 1697 if (TYPE_STUB (target_type)) 1698 p_bounds = value_cast (lookup_pointer_type 1699 (ada_check_typedef (target_type)), 1700 p_bounds); 1701 } 1702 else 1703 error (_("Bad GNAT array descriptor")); 1704 1705 return p_bounds; 1706 } 1707 else 1708 return NULL; 1709} 1710 1711/* If TYPE is the type of an array-descriptor (fat pointer), the bit 1712 position of the field containing the address of the bounds data. */ 1713 1714static int 1715fat_pntr_bounds_bitpos (struct type *type) 1716{ 1717 return TYPE_FIELD_BITPOS (desc_base_type (type), 1); 1718} 1719 1720/* If TYPE is the type of an array-descriptor (fat pointer), the bit 1721 size of the field containing the address of the bounds data. */ 1722 1723static int 1724fat_pntr_bounds_bitsize (struct type *type) 1725{ 1726 type = desc_base_type (type); 1727 1728 if (TYPE_FIELD_BITSIZE (type, 1) > 0) 1729 return TYPE_FIELD_BITSIZE (type, 1); 1730 else 1731 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1))); 1732} 1733 1734/* If TYPE is the type of an array descriptor (fat or thin pointer) or a 1735 pointer to one, the type of its array data (a array-with-no-bounds type); 1736 otherwise, NULL. Use ada_type_of_array to get an array type with bounds 1737 data. */ 1738 1739static struct type * 1740desc_data_target_type (struct type *type) 1741{ 1742 type = desc_base_type (type); 1743 1744 /* NOTE: The following is bogus; see comment in desc_bounds. */ 1745 if (is_thin_pntr (type)) 1746 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)); 1747 else if (is_thick_pntr (type)) 1748 { 1749 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1); 1750 1751 if (data_type 1752 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR) 1753 return ada_check_typedef (TYPE_TARGET_TYPE (data_type)); 1754 } 1755 1756 return NULL; 1757} 1758 1759/* If ARR is an array descriptor (fat or thin pointer), a pointer to 1760 its array data. */ 1761 1762static struct value * 1763desc_data (struct value *arr) 1764{ 1765 struct type *type = value_type (arr); 1766 1767 if (is_thin_pntr (type)) 1768 return thin_data_pntr (arr); 1769 else if (is_thick_pntr (type)) 1770 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL, 1771 _("Bad GNAT array descriptor")); 1772 else 1773 return NULL; 1774} 1775 1776 1777/* If TYPE is the type of an array-descriptor (fat pointer), the bit 1778 position of the field containing the address of the data. */ 1779 1780static int 1781fat_pntr_data_bitpos (struct type *type) 1782{ 1783 return TYPE_FIELD_BITPOS (desc_base_type (type), 0); 1784} 1785 1786/* If TYPE is the type of an array-descriptor (fat pointer), the bit 1787 size of the field containing the address of the data. */ 1788 1789static int 1790fat_pntr_data_bitsize (struct type *type) 1791{ 1792 type = desc_base_type (type); 1793 1794 if (TYPE_FIELD_BITSIZE (type, 0) > 0) 1795 return TYPE_FIELD_BITSIZE (type, 0); 1796 else 1797 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0)); 1798} 1799 1800/* If BOUNDS is an array-bounds structure (or pointer to one), return 1801 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1802 bound, if WHICH is 1. The first bound is I=1. */ 1803 1804static struct value * 1805desc_one_bound (struct value *bounds, int i, int which) 1806{ 1807 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL, 1808 _("Bad GNAT array descriptor bounds")); 1809} 1810 1811/* If BOUNDS is an array-bounds structure type, return the bit position 1812 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1813 bound, if WHICH is 1. The first bound is I=1. */ 1814 1815static int 1816desc_bound_bitpos (struct type *type, int i, int which) 1817{ 1818 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2); 1819} 1820 1821/* If BOUNDS is an array-bounds structure type, return the bit field size 1822 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper 1823 bound, if WHICH is 1. The first bound is I=1. */ 1824 1825static int 1826desc_bound_bitsize (struct type *type, int i, int which) 1827{ 1828 type = desc_base_type (type); 1829 1830 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0) 1831 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2); 1832 else 1833 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2)); 1834} 1835 1836/* If TYPE is the type of an array-bounds structure, the type of its 1837 Ith bound (numbering from 1). Otherwise, NULL. */ 1838 1839static struct type * 1840desc_index_type (struct type *type, int i) 1841{ 1842 type = desc_base_type (type); 1843 1844 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 1845 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1); 1846 else 1847 return NULL; 1848} 1849 1850/* The number of index positions in the array-bounds type TYPE. 1851 Return 0 if TYPE is NULL. */ 1852 1853static int 1854desc_arity (struct type *type) 1855{ 1856 type = desc_base_type (type); 1857 1858 if (type != NULL) 1859 return TYPE_NFIELDS (type) / 2; 1860 return 0; 1861} 1862 1863/* Non-zero iff TYPE is a simple array type (not a pointer to one) or 1864 an array descriptor type (representing an unconstrained array 1865 type). */ 1866 1867static int 1868ada_is_direct_array_type (struct type *type) 1869{ 1870 if (type == NULL) 1871 return 0; 1872 type = ada_check_typedef (type); 1873 return (TYPE_CODE (type) == TYPE_CODE_ARRAY 1874 || ada_is_array_descriptor_type (type)); 1875} 1876 1877/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer 1878 * to one. */ 1879 1880static int 1881ada_is_array_type (struct type *type) 1882{ 1883 while (type != NULL 1884 && (TYPE_CODE (type) == TYPE_CODE_PTR 1885 || TYPE_CODE (type) == TYPE_CODE_REF)) 1886 type = TYPE_TARGET_TYPE (type); 1887 return ada_is_direct_array_type (type); 1888} 1889 1890/* Non-zero iff TYPE is a simple array type or pointer to one. */ 1891 1892int 1893ada_is_simple_array_type (struct type *type) 1894{ 1895 if (type == NULL) 1896 return 0; 1897 type = ada_check_typedef (type); 1898 return (TYPE_CODE (type) == TYPE_CODE_ARRAY 1899 || (TYPE_CODE (type) == TYPE_CODE_PTR 1900 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))) 1901 == TYPE_CODE_ARRAY)); 1902} 1903 1904/* Non-zero iff TYPE belongs to a GNAT array descriptor. */ 1905 1906int 1907ada_is_array_descriptor_type (struct type *type) 1908{ 1909 struct type *data_type = desc_data_target_type (type); 1910 1911 if (type == NULL) 1912 return 0; 1913 type = ada_check_typedef (type); 1914 return (data_type != NULL 1915 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY 1916 && desc_arity (desc_bounds_type (type)) > 0); 1917} 1918 1919/* Non-zero iff type is a partially mal-formed GNAT array 1920 descriptor. FIXME: This is to compensate for some problems with 1921 debugging output from GNAT. Re-examine periodically to see if it 1922 is still needed. */ 1923 1924int 1925ada_is_bogus_array_descriptor (struct type *type) 1926{ 1927 return 1928 type != NULL 1929 && TYPE_CODE (type) == TYPE_CODE_STRUCT 1930 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL 1931 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL) 1932 && !ada_is_array_descriptor_type (type); 1933} 1934 1935 1936/* If ARR has a record type in the form of a standard GNAT array descriptor, 1937 (fat pointer) returns the type of the array data described---specifically, 1938 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled 1939 in from the descriptor; otherwise, they are left unspecified. If 1940 the ARR denotes a null array descriptor and BOUNDS is non-zero, 1941 returns NULL. The result is simply the type of ARR if ARR is not 1942 a descriptor. */ 1943struct type * 1944ada_type_of_array (struct value *arr, int bounds) 1945{ 1946 if (ada_is_constrained_packed_array_type (value_type (arr))) 1947 return decode_constrained_packed_array_type (value_type (arr)); 1948 1949 if (!ada_is_array_descriptor_type (value_type (arr))) 1950 return value_type (arr); 1951 1952 if (!bounds) 1953 { 1954 struct type *array_type = 1955 ada_check_typedef (desc_data_target_type (value_type (arr))); 1956 1957 if (ada_is_unconstrained_packed_array_type (value_type (arr))) 1958 TYPE_FIELD_BITSIZE (array_type, 0) = 1959 decode_packed_array_bitsize (value_type (arr)); 1960 1961 return array_type; 1962 } 1963 else 1964 { 1965 struct type *elt_type; 1966 int arity; 1967 struct value *descriptor; 1968 1969 elt_type = ada_array_element_type (value_type (arr), -1); 1970 arity = ada_array_arity (value_type (arr)); 1971 1972 if (elt_type == NULL || arity == 0) 1973 return ada_check_typedef (value_type (arr)); 1974 1975 descriptor = desc_bounds (arr); 1976 if (value_as_long (descriptor) == 0) 1977 return NULL; 1978 while (arity > 0) 1979 { 1980 struct type *range_type = alloc_type_copy (value_type (arr)); 1981 struct type *array_type = alloc_type_copy (value_type (arr)); 1982 struct value *low = desc_one_bound (descriptor, arity, 0); 1983 struct value *high = desc_one_bound (descriptor, arity, 1); 1984 1985 arity -= 1; 1986 create_static_range_type (range_type, value_type (low), 1987 longest_to_int (value_as_long (low)), 1988 longest_to_int (value_as_long (high))); 1989 elt_type = create_array_type (array_type, elt_type, range_type); 1990 1991 if (ada_is_unconstrained_packed_array_type (value_type (arr))) 1992 { 1993 /* We need to store the element packed bitsize, as well as 1994 recompute the array size, because it was previously 1995 computed based on the unpacked element size. */ 1996 LONGEST lo = value_as_long (low); 1997 LONGEST hi = value_as_long (high); 1998 1999 TYPE_FIELD_BITSIZE (elt_type, 0) = 2000 decode_packed_array_bitsize (value_type (arr)); 2001 /* If the array has no element, then the size is already 2002 zero, and does not need to be recomputed. */ 2003 if (lo < hi) 2004 { 2005 int array_bitsize = 2006 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0); 2007 2008 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8; 2009 } 2010 } 2011 } 2012 2013 return lookup_pointer_type (elt_type); 2014 } 2015} 2016 2017/* If ARR does not represent an array, returns ARR unchanged. 2018 Otherwise, returns either a standard GDB array with bounds set 2019 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard 2020 GDB array. Returns NULL if ARR is a null fat pointer. */ 2021 2022struct value * 2023ada_coerce_to_simple_array_ptr (struct value *arr) 2024{ 2025 if (ada_is_array_descriptor_type (value_type (arr))) 2026 { 2027 struct type *arrType = ada_type_of_array (arr, 1); 2028 2029 if (arrType == NULL) 2030 return NULL; 2031 return value_cast (arrType, value_copy (desc_data (arr))); 2032 } 2033 else if (ada_is_constrained_packed_array_type (value_type (arr))) 2034 return decode_constrained_packed_array (arr); 2035 else 2036 return arr; 2037} 2038 2039/* If ARR does not represent an array, returns ARR unchanged. 2040 Otherwise, returns a standard GDB array describing ARR (which may 2041 be ARR itself if it already is in the proper form). */ 2042 2043struct value * 2044ada_coerce_to_simple_array (struct value *arr) 2045{ 2046 if (ada_is_array_descriptor_type (value_type (arr))) 2047 { 2048 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr); 2049 2050 if (arrVal == NULL) 2051 error (_("Bounds unavailable for null array pointer.")); 2052 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal))); 2053 return value_ind (arrVal); 2054 } 2055 else if (ada_is_constrained_packed_array_type (value_type (arr))) 2056 return decode_constrained_packed_array (arr); 2057 else 2058 return arr; 2059} 2060 2061/* If TYPE represents a GNAT array type, return it translated to an 2062 ordinary GDB array type (possibly with BITSIZE fields indicating 2063 packing). For other types, is the identity. */ 2064 2065struct type * 2066ada_coerce_to_simple_array_type (struct type *type) 2067{ 2068 if (ada_is_constrained_packed_array_type (type)) 2069 return decode_constrained_packed_array_type (type); 2070 2071 if (ada_is_array_descriptor_type (type)) 2072 return ada_check_typedef (desc_data_target_type (type)); 2073 2074 return type; 2075} 2076 2077/* Non-zero iff TYPE represents a standard GNAT packed-array type. */ 2078 2079static int 2080ada_is_packed_array_type (struct type *type) 2081{ 2082 if (type == NULL) 2083 return 0; 2084 type = desc_base_type (type); 2085 type = ada_check_typedef (type); 2086 return 2087 ada_type_name (type) != NULL 2088 && strstr (ada_type_name (type), "___XP") != NULL; 2089} 2090 2091/* Non-zero iff TYPE represents a standard GNAT constrained 2092 packed-array type. */ 2093 2094int 2095ada_is_constrained_packed_array_type (struct type *type) 2096{ 2097 return ada_is_packed_array_type (type) 2098 && !ada_is_array_descriptor_type (type); 2099} 2100 2101/* Non-zero iff TYPE represents an array descriptor for a 2102 unconstrained packed-array type. */ 2103 2104static int 2105ada_is_unconstrained_packed_array_type (struct type *type) 2106{ 2107 return ada_is_packed_array_type (type) 2108 && ada_is_array_descriptor_type (type); 2109} 2110 2111/* Given that TYPE encodes a packed array type (constrained or unconstrained), 2112 return the size of its elements in bits. */ 2113 2114static long 2115decode_packed_array_bitsize (struct type *type) 2116{ 2117 const char *raw_name; 2118 const char *tail; 2119 long bits; 2120 2121 /* Access to arrays implemented as fat pointers are encoded as a typedef 2122 of the fat pointer type. We need the name of the fat pointer type 2123 to do the decoding, so strip the typedef layer. */ 2124 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 2125 type = ada_typedef_target_type (type); 2126 2127 raw_name = ada_type_name (ada_check_typedef (type)); 2128 if (!raw_name) 2129 raw_name = ada_type_name (desc_base_type (type)); 2130 2131 if (!raw_name) 2132 return 0; 2133 2134 tail = strstr (raw_name, "___XP"); 2135 gdb_assert (tail != NULL); 2136 2137 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1) 2138 { 2139 lim_warning 2140 (_("could not understand bit size information on packed array")); 2141 return 0; 2142 } 2143 2144 return bits; 2145} 2146 2147/* Given that TYPE is a standard GDB array type with all bounds filled 2148 in, and that the element size of its ultimate scalar constituents 2149 (that is, either its elements, or, if it is an array of arrays, its 2150 elements' elements, etc.) is *ELT_BITS, return an identical type, 2151 but with the bit sizes of its elements (and those of any 2152 constituent arrays) recorded in the BITSIZE components of its 2153 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size 2154 in bits. 2155 2156 Note that, for arrays whose index type has an XA encoding where 2157 a bound references a record discriminant, getting that discriminant, 2158 and therefore the actual value of that bound, is not possible 2159 because none of the given parameters gives us access to the record. 2160 This function assumes that it is OK in the context where it is being 2161 used to return an array whose bounds are still dynamic and where 2162 the length is arbitrary. */ 2163 2164static struct type * 2165constrained_packed_array_type (struct type *type, long *elt_bits) 2166{ 2167 struct type *new_elt_type; 2168 struct type *new_type; 2169 struct type *index_type_desc; 2170 struct type *index_type; 2171 LONGEST low_bound, high_bound; 2172 2173 type = ada_check_typedef (type); 2174 if (TYPE_CODE (type) != TYPE_CODE_ARRAY) 2175 return type; 2176 2177 index_type_desc = ada_find_parallel_type (type, "___XA"); 2178 if (index_type_desc) 2179 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0), 2180 NULL); 2181 else 2182 index_type = TYPE_INDEX_TYPE (type); 2183 2184 new_type = alloc_type_copy (type); 2185 new_elt_type = 2186 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)), 2187 elt_bits); 2188 create_array_type (new_type, new_elt_type, index_type); 2189 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits; 2190 TYPE_NAME (new_type) = ada_type_name (type); 2191 2192 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE 2193 && is_dynamic_type (check_typedef (index_type))) 2194 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0) 2195 low_bound = high_bound = 0; 2196 if (high_bound < low_bound) 2197 *elt_bits = TYPE_LENGTH (new_type) = 0; 2198 else 2199 { 2200 *elt_bits *= (high_bound - low_bound + 1); 2201 TYPE_LENGTH (new_type) = 2202 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT; 2203 } 2204 2205 TYPE_FIXED_INSTANCE (new_type) = 1; 2206 return new_type; 2207} 2208 2209/* The array type encoded by TYPE, where 2210 ada_is_constrained_packed_array_type (TYPE). */ 2211 2212static struct type * 2213decode_constrained_packed_array_type (struct type *type) 2214{ 2215 const char *raw_name = ada_type_name (ada_check_typedef (type)); 2216 char *name; 2217 const char *tail; 2218 struct type *shadow_type; 2219 long bits; 2220 2221 if (!raw_name) 2222 raw_name = ada_type_name (desc_base_type (type)); 2223 2224 if (!raw_name) 2225 return NULL; 2226 2227 name = (char *) alloca (strlen (raw_name) + 1); 2228 tail = strstr (raw_name, "___XP"); 2229 type = desc_base_type (type); 2230 2231 memcpy (name, raw_name, tail - raw_name); 2232 name[tail - raw_name] = '\000'; 2233 2234 shadow_type = ada_find_parallel_type_with_name (type, name); 2235 2236 if (shadow_type == NULL) 2237 { 2238 lim_warning (_("could not find bounds information on packed array")); 2239 return NULL; 2240 } 2241 CHECK_TYPEDEF (shadow_type); 2242 2243 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY) 2244 { 2245 lim_warning (_("could not understand bounds " 2246 "information on packed array")); 2247 return NULL; 2248 } 2249 2250 bits = decode_packed_array_bitsize (type); 2251 return constrained_packed_array_type (shadow_type, &bits); 2252} 2253 2254/* Given that ARR is a struct value *indicating a GNAT constrained packed 2255 array, returns a simple array that denotes that array. Its type is a 2256 standard GDB array type except that the BITSIZEs of the array 2257 target types are set to the number of bits in each element, and the 2258 type length is set appropriately. */ 2259 2260static struct value * 2261decode_constrained_packed_array (struct value *arr) 2262{ 2263 struct type *type; 2264 2265 /* If our value is a pointer, then dereference it. Likewise if 2266 the value is a reference. Make sure that this operation does not 2267 cause the target type to be fixed, as this would indirectly cause 2268 this array to be decoded. The rest of the routine assumes that 2269 the array hasn't been decoded yet, so we use the basic "coerce_ref" 2270 and "value_ind" routines to perform the dereferencing, as opposed 2271 to using "ada_coerce_ref" or "ada_value_ind". */ 2272 arr = coerce_ref (arr); 2273 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR) 2274 arr = value_ind (arr); 2275 2276 type = decode_constrained_packed_array_type (value_type (arr)); 2277 if (type == NULL) 2278 { 2279 error (_("can't unpack array")); 2280 return NULL; 2281 } 2282 2283 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr))) 2284 && ada_is_modular_type (value_type (arr))) 2285 { 2286 /* This is a (right-justified) modular type representing a packed 2287 array with no wrapper. In order to interpret the value through 2288 the (left-justified) packed array type we just built, we must 2289 first left-justify it. */ 2290 int bit_size, bit_pos; 2291 ULONGEST mod; 2292 2293 mod = ada_modulus (value_type (arr)) - 1; 2294 bit_size = 0; 2295 while (mod > 0) 2296 { 2297 bit_size += 1; 2298 mod >>= 1; 2299 } 2300 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size; 2301 arr = ada_value_primitive_packed_val (arr, NULL, 2302 bit_pos / HOST_CHAR_BIT, 2303 bit_pos % HOST_CHAR_BIT, 2304 bit_size, 2305 type); 2306 } 2307 2308 return coerce_unspec_val_to_type (arr, type); 2309} 2310 2311 2312/* The value of the element of packed array ARR at the ARITY indices 2313 given in IND. ARR must be a simple array. */ 2314 2315static struct value * 2316value_subscript_packed (struct value *arr, int arity, struct value **ind) 2317{ 2318 int i; 2319 int bits, elt_off, bit_off; 2320 long elt_total_bit_offset; 2321 struct type *elt_type; 2322 struct value *v; 2323 2324 bits = 0; 2325 elt_total_bit_offset = 0; 2326 elt_type = ada_check_typedef (value_type (arr)); 2327 for (i = 0; i < arity; i += 1) 2328 { 2329 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY 2330 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0) 2331 error 2332 (_("attempt to do packed indexing of " 2333 "something other than a packed array")); 2334 else 2335 { 2336 struct type *range_type = TYPE_INDEX_TYPE (elt_type); 2337 LONGEST lowerbound, upperbound; 2338 LONGEST idx; 2339 2340 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0) 2341 { 2342 lim_warning (_("don't know bounds of array")); 2343 lowerbound = upperbound = 0; 2344 } 2345 2346 idx = pos_atr (ind[i]); 2347 if (idx < lowerbound || idx > upperbound) 2348 lim_warning (_("packed array index %ld out of bounds"), 2349 (long) idx); 2350 bits = TYPE_FIELD_BITSIZE (elt_type, 0); 2351 elt_total_bit_offset += (idx - lowerbound) * bits; 2352 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type)); 2353 } 2354 } 2355 elt_off = elt_total_bit_offset / HOST_CHAR_BIT; 2356 bit_off = elt_total_bit_offset % HOST_CHAR_BIT; 2357 2358 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off, 2359 bits, elt_type); 2360 return v; 2361} 2362 2363/* Non-zero iff TYPE includes negative integer values. */ 2364 2365static int 2366has_negatives (struct type *type) 2367{ 2368 switch (TYPE_CODE (type)) 2369 { 2370 default: 2371 return 0; 2372 case TYPE_CODE_INT: 2373 return !TYPE_UNSIGNED (type); 2374 case TYPE_CODE_RANGE: 2375 return TYPE_LOW_BOUND (type) < 0; 2376 } 2377} 2378 2379 2380/* Create a new value of type TYPE from the contents of OBJ starting 2381 at byte OFFSET, and bit offset BIT_OFFSET within that byte, 2382 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then 2383 assigning through the result will set the field fetched from. 2384 VALADDR is ignored unless OBJ is NULL, in which case, 2385 VALADDR+OFFSET must address the start of storage containing the 2386 packed value. The value returned in this case is never an lval. 2387 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */ 2388 2389struct value * 2390ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr, 2391 long offset, int bit_offset, int bit_size, 2392 struct type *type) 2393{ 2394 struct value *v; 2395 int src, /* Index into the source area */ 2396 targ, /* Index into the target area */ 2397 srcBitsLeft, /* Number of source bits left to move */ 2398 nsrc, ntarg, /* Number of source and target bytes */ 2399 unusedLS, /* Number of bits in next significant 2400 byte of source that are unused */ 2401 accumSize; /* Number of meaningful bits in accum */ 2402 unsigned char *bytes; /* First byte containing data to unpack */ 2403 unsigned char *unpacked; 2404 unsigned long accum; /* Staging area for bits being transferred */ 2405 unsigned char sign; 2406 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8; 2407 /* Transmit bytes from least to most significant; delta is the direction 2408 the indices move. */ 2409 int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1; 2410 2411 type = ada_check_typedef (type); 2412 2413 if (obj == NULL) 2414 { 2415 v = allocate_value (type); 2416 bytes = (unsigned char *) (valaddr + offset); 2417 } 2418 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj)) 2419 { 2420 v = value_at (type, value_address (obj) + offset); 2421 type = value_type (v); 2422 if (TYPE_LENGTH (type) * HOST_CHAR_BIT < bit_size) 2423 { 2424 /* This can happen in the case of an array of dynamic objects, 2425 where the size of each element changes from element to element. 2426 In that case, we're initially given the array stride, but 2427 after resolving the element type, we find that its size is 2428 less than this stride. In that case, adjust bit_size to 2429 match TYPE's length, and recompute LEN accordingly. */ 2430 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT; 2431 len = TYPE_LENGTH (type) + (bit_offset + HOST_CHAR_BIT - 1) / 8; 2432 } 2433 bytes = (unsigned char *) alloca (len); 2434 read_memory (value_address (v), bytes, len); 2435 } 2436 else 2437 { 2438 v = allocate_value (type); 2439 bytes = (unsigned char *) value_contents (obj) + offset; 2440 } 2441 2442 if (obj != NULL) 2443 { 2444 long new_offset = offset; 2445 2446 set_value_component_location (v, obj); 2447 set_value_bitpos (v, bit_offset + value_bitpos (obj)); 2448 set_value_bitsize (v, bit_size); 2449 if (value_bitpos (v) >= HOST_CHAR_BIT) 2450 { 2451 ++new_offset; 2452 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT); 2453 } 2454 set_value_offset (v, new_offset); 2455 2456 /* Also set the parent value. This is needed when trying to 2457 assign a new value (in inferior memory). */ 2458 set_value_parent (v, obj); 2459 } 2460 else 2461 set_value_bitsize (v, bit_size); 2462 unpacked = (unsigned char *) value_contents (v); 2463 2464 srcBitsLeft = bit_size; 2465 nsrc = len; 2466 ntarg = TYPE_LENGTH (type); 2467 sign = 0; 2468 if (bit_size == 0) 2469 { 2470 memset (unpacked, 0, TYPE_LENGTH (type)); 2471 return v; 2472 } 2473 else if (gdbarch_bits_big_endian (get_type_arch (type))) 2474 { 2475 src = len - 1; 2476 if (has_negatives (type) 2477 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1)))) 2478 sign = ~0; 2479 2480 unusedLS = 2481 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT) 2482 % HOST_CHAR_BIT; 2483 2484 switch (TYPE_CODE (type)) 2485 { 2486 case TYPE_CODE_ARRAY: 2487 case TYPE_CODE_UNION: 2488 case TYPE_CODE_STRUCT: 2489 /* Non-scalar values must be aligned at a byte boundary... */ 2490 accumSize = 2491 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT; 2492 /* ... And are placed at the beginning (most-significant) bytes 2493 of the target. */ 2494 targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1; 2495 ntarg = targ + 1; 2496 break; 2497 default: 2498 accumSize = 0; 2499 targ = TYPE_LENGTH (type) - 1; 2500 break; 2501 } 2502 } 2503 else 2504 { 2505 int sign_bit_offset = (bit_size + bit_offset - 1) % 8; 2506 2507 src = targ = 0; 2508 unusedLS = bit_offset; 2509 accumSize = 0; 2510 2511 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset))) 2512 sign = ~0; 2513 } 2514 2515 accum = 0; 2516 while (nsrc > 0) 2517 { 2518 /* Mask for removing bits of the next source byte that are not 2519 part of the value. */ 2520 unsigned int unusedMSMask = 2521 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) - 2522 1; 2523 /* Sign-extend bits for this byte. */ 2524 unsigned int signMask = sign & ~unusedMSMask; 2525 2526 accum |= 2527 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize; 2528 accumSize += HOST_CHAR_BIT - unusedLS; 2529 if (accumSize >= HOST_CHAR_BIT) 2530 { 2531 unpacked[targ] = accum & ~(~0UL << HOST_CHAR_BIT); 2532 accumSize -= HOST_CHAR_BIT; 2533 accum >>= HOST_CHAR_BIT; 2534 ntarg -= 1; 2535 targ += delta; 2536 } 2537 srcBitsLeft -= HOST_CHAR_BIT - unusedLS; 2538 unusedLS = 0; 2539 nsrc -= 1; 2540 src += delta; 2541 } 2542 while (ntarg > 0) 2543 { 2544 accum |= sign << accumSize; 2545 unpacked[targ] = accum & ~(~0UL << HOST_CHAR_BIT); 2546 accumSize -= HOST_CHAR_BIT; 2547 if (accumSize < 0) 2548 accumSize = 0; 2549 accum >>= HOST_CHAR_BIT; 2550 ntarg -= 1; 2551 targ += delta; 2552 } 2553 2554 if (is_dynamic_type (value_type (v))) 2555 v = value_from_contents_and_address (value_type (v), value_contents (v), 2556 0); 2557 return v; 2558} 2559 2560/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to 2561 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must 2562 not overlap. */ 2563static void 2564move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source, 2565 int src_offset, int n, int bits_big_endian_p) 2566{ 2567 unsigned int accum, mask; 2568 int accum_bits, chunk_size; 2569 2570 target += targ_offset / HOST_CHAR_BIT; 2571 targ_offset %= HOST_CHAR_BIT; 2572 source += src_offset / HOST_CHAR_BIT; 2573 src_offset %= HOST_CHAR_BIT; 2574 if (bits_big_endian_p) 2575 { 2576 accum = (unsigned char) *source; 2577 source += 1; 2578 accum_bits = HOST_CHAR_BIT - src_offset; 2579 2580 while (n > 0) 2581 { 2582 int unused_right; 2583 2584 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source; 2585 accum_bits += HOST_CHAR_BIT; 2586 source += 1; 2587 chunk_size = HOST_CHAR_BIT - targ_offset; 2588 if (chunk_size > n) 2589 chunk_size = n; 2590 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset); 2591 mask = ((1 << chunk_size) - 1) << unused_right; 2592 *target = 2593 (*target & ~mask) 2594 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask); 2595 n -= chunk_size; 2596 accum_bits -= chunk_size; 2597 target += 1; 2598 targ_offset = 0; 2599 } 2600 } 2601 else 2602 { 2603 accum = (unsigned char) *source >> src_offset; 2604 source += 1; 2605 accum_bits = HOST_CHAR_BIT - src_offset; 2606 2607 while (n > 0) 2608 { 2609 accum = accum + ((unsigned char) *source << accum_bits); 2610 accum_bits += HOST_CHAR_BIT; 2611 source += 1; 2612 chunk_size = HOST_CHAR_BIT - targ_offset; 2613 if (chunk_size > n) 2614 chunk_size = n; 2615 mask = ((1 << chunk_size) - 1) << targ_offset; 2616 *target = (*target & ~mask) | ((accum << targ_offset) & mask); 2617 n -= chunk_size; 2618 accum_bits -= chunk_size; 2619 accum >>= chunk_size; 2620 target += 1; 2621 targ_offset = 0; 2622 } 2623 } 2624} 2625 2626/* Store the contents of FROMVAL into the location of TOVAL. 2627 Return a new value with the location of TOVAL and contents of 2628 FROMVAL. Handles assignment into packed fields that have 2629 floating-point or non-scalar types. */ 2630 2631static struct value * 2632ada_value_assign (struct value *toval, struct value *fromval) 2633{ 2634 struct type *type = value_type (toval); 2635 int bits = value_bitsize (toval); 2636 2637 toval = ada_coerce_ref (toval); 2638 fromval = ada_coerce_ref (fromval); 2639 2640 if (ada_is_direct_array_type (value_type (toval))) 2641 toval = ada_coerce_to_simple_array (toval); 2642 if (ada_is_direct_array_type (value_type (fromval))) 2643 fromval = ada_coerce_to_simple_array (fromval); 2644 2645 if (!deprecated_value_modifiable (toval)) 2646 error (_("Left operand of assignment is not a modifiable lvalue.")); 2647 2648 if (VALUE_LVAL (toval) == lval_memory 2649 && bits > 0 2650 && (TYPE_CODE (type) == TYPE_CODE_FLT 2651 || TYPE_CODE (type) == TYPE_CODE_STRUCT)) 2652 { 2653 int len = (value_bitpos (toval) 2654 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT; 2655 int from_size; 2656 gdb_byte *buffer = alloca (len); 2657 struct value *val; 2658 CORE_ADDR to_addr = value_address (toval); 2659 2660 if (TYPE_CODE (type) == TYPE_CODE_FLT) 2661 fromval = value_cast (type, fromval); 2662 2663 read_memory (to_addr, buffer, len); 2664 from_size = value_bitsize (fromval); 2665 if (from_size == 0) 2666 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT; 2667 if (gdbarch_bits_big_endian (get_type_arch (type))) 2668 move_bits (buffer, value_bitpos (toval), 2669 value_contents (fromval), from_size - bits, bits, 1); 2670 else 2671 move_bits (buffer, value_bitpos (toval), 2672 value_contents (fromval), 0, bits, 0); 2673 write_memory_with_notification (to_addr, buffer, len); 2674 2675 val = value_copy (toval); 2676 memcpy (value_contents_raw (val), value_contents (fromval), 2677 TYPE_LENGTH (type)); 2678 deprecated_set_value_type (val, type); 2679 2680 return val; 2681 } 2682 2683 return value_assign (toval, fromval); 2684} 2685 2686 2687/* Given that COMPONENT is a memory lvalue that is part of the lvalue 2688 CONTAINER, assign the contents of VAL to COMPONENTS's place in 2689 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not 2690 COMPONENT, and not the inferior's memory. The current contents 2691 of COMPONENT are ignored. 2692 2693 Although not part of the initial design, this function also works 2694 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER 2695 had a null address, and COMPONENT had an address which is equal to 2696 its offset inside CONTAINER. */ 2697 2698static void 2699value_assign_to_component (struct value *container, struct value *component, 2700 struct value *val) 2701{ 2702 LONGEST offset_in_container = 2703 (LONGEST) (value_address (component) - value_address (container)); 2704 int bit_offset_in_container = 2705 value_bitpos (component) - value_bitpos (container); 2706 int bits; 2707 2708 val = value_cast (value_type (component), val); 2709 2710 if (value_bitsize (component) == 0) 2711 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component)); 2712 else 2713 bits = value_bitsize (component); 2714 2715 if (gdbarch_bits_big_endian (get_type_arch (value_type (container)))) 2716 move_bits (value_contents_writeable (container) + offset_in_container, 2717 value_bitpos (container) + bit_offset_in_container, 2718 value_contents (val), 2719 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits, 2720 bits, 1); 2721 else 2722 move_bits (value_contents_writeable (container) + offset_in_container, 2723 value_bitpos (container) + bit_offset_in_container, 2724 value_contents (val), 0, bits, 0); 2725} 2726 2727/* The value of the element of array ARR at the ARITY indices given in IND. 2728 ARR may be either a simple array, GNAT array descriptor, or pointer 2729 thereto. */ 2730 2731struct value * 2732ada_value_subscript (struct value *arr, int arity, struct value **ind) 2733{ 2734 int k; 2735 struct value *elt; 2736 struct type *elt_type; 2737 2738 elt = ada_coerce_to_simple_array (arr); 2739 2740 elt_type = ada_check_typedef (value_type (elt)); 2741 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY 2742 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0) 2743 return value_subscript_packed (elt, arity, ind); 2744 2745 for (k = 0; k < arity; k += 1) 2746 { 2747 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY) 2748 error (_("too many subscripts (%d expected)"), k); 2749 elt = value_subscript (elt, pos_atr (ind[k])); 2750 } 2751 return elt; 2752} 2753 2754/* Assuming ARR is a pointer to a GDB array, the value of the element 2755 of *ARR at the ARITY indices given in IND. 2756 Does not read the entire array into memory. */ 2757 2758static struct value * 2759ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind) 2760{ 2761 int k; 2762 struct type *type 2763 = check_typedef (value_enclosing_type (ada_value_ind (arr))); 2764 2765 for (k = 0; k < arity; k += 1) 2766 { 2767 LONGEST lwb, upb; 2768 struct value *lwb_value; 2769 2770 if (TYPE_CODE (type) != TYPE_CODE_ARRAY) 2771 error (_("too many subscripts (%d expected)"), k); 2772 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)), 2773 value_copy (arr)); 2774 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb); 2775 lwb_value = value_from_longest (value_type(ind[k]), lwb); 2776 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value)); 2777 type = TYPE_TARGET_TYPE (type); 2778 } 2779 2780 return value_ind (arr); 2781} 2782 2783/* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the 2784 actual type of ARRAY_PTR is ignored), returns the Ada slice of 2785 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of 2786 this array is LOW, as per Ada rules. */ 2787static struct value * 2788ada_value_slice_from_ptr (struct value *array_ptr, struct type *type, 2789 int low, int high) 2790{ 2791 struct type *type0 = ada_check_typedef (type); 2792 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0)); 2793 struct type *index_type 2794 = create_static_range_type (NULL, base_index_type, low, high); 2795 struct type *slice_type = 2796 create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type); 2797 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0)); 2798 LONGEST base_low_pos, low_pos; 2799 CORE_ADDR base; 2800 2801 if (!discrete_position (base_index_type, low, &low_pos) 2802 || !discrete_position (base_index_type, base_low, &base_low_pos)) 2803 { 2804 warning (_("unable to get positions in slice, use bounds instead")); 2805 low_pos = low; 2806 base_low_pos = base_low; 2807 } 2808 2809 base = value_as_address (array_ptr) 2810 + ((low_pos - base_low_pos) 2811 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0))); 2812 return value_at_lazy (slice_type, base); 2813} 2814 2815 2816static struct value * 2817ada_value_slice (struct value *array, int low, int high) 2818{ 2819 struct type *type = ada_check_typedef (value_type (array)); 2820 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)); 2821 struct type *index_type 2822 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high); 2823 struct type *slice_type = 2824 create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type); 2825 LONGEST low_pos, high_pos; 2826 2827 if (!discrete_position (base_index_type, low, &low_pos) 2828 || !discrete_position (base_index_type, high, &high_pos)) 2829 { 2830 warning (_("unable to get positions in slice, use bounds instead")); 2831 low_pos = low; 2832 high_pos = high; 2833 } 2834 2835 return value_cast (slice_type, 2836 value_slice (array, low, high_pos - low_pos + 1)); 2837} 2838 2839/* If type is a record type in the form of a standard GNAT array 2840 descriptor, returns the number of dimensions for type. If arr is a 2841 simple array, returns the number of "array of"s that prefix its 2842 type designation. Otherwise, returns 0. */ 2843 2844int 2845ada_array_arity (struct type *type) 2846{ 2847 int arity; 2848 2849 if (type == NULL) 2850 return 0; 2851 2852 type = desc_base_type (type); 2853 2854 arity = 0; 2855 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 2856 return desc_arity (desc_bounds_type (type)); 2857 else 2858 while (TYPE_CODE (type) == TYPE_CODE_ARRAY) 2859 { 2860 arity += 1; 2861 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 2862 } 2863 2864 return arity; 2865} 2866 2867/* If TYPE is a record type in the form of a standard GNAT array 2868 descriptor or a simple array type, returns the element type for 2869 TYPE after indexing by NINDICES indices, or by all indices if 2870 NINDICES is -1. Otherwise, returns NULL. */ 2871 2872struct type * 2873ada_array_element_type (struct type *type, int nindices) 2874{ 2875 type = desc_base_type (type); 2876 2877 if (TYPE_CODE (type) == TYPE_CODE_STRUCT) 2878 { 2879 int k; 2880 struct type *p_array_type; 2881 2882 p_array_type = desc_data_target_type (type); 2883 2884 k = ada_array_arity (type); 2885 if (k == 0) 2886 return NULL; 2887 2888 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */ 2889 if (nindices >= 0 && k > nindices) 2890 k = nindices; 2891 while (k > 0 && p_array_type != NULL) 2892 { 2893 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type)); 2894 k -= 1; 2895 } 2896 return p_array_type; 2897 } 2898 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY) 2899 { 2900 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 2901 { 2902 type = TYPE_TARGET_TYPE (type); 2903 nindices -= 1; 2904 } 2905 return type; 2906 } 2907 2908 return NULL; 2909} 2910 2911/* The type of nth index in arrays of given type (n numbering from 1). 2912 Does not examine memory. Throws an error if N is invalid or TYPE 2913 is not an array type. NAME is the name of the Ada attribute being 2914 evaluated ('range, 'first, 'last, or 'length); it is used in building 2915 the error message. */ 2916 2917static struct type * 2918ada_index_type (struct type *type, int n, const char *name) 2919{ 2920 struct type *result_type; 2921 2922 type = desc_base_type (type); 2923 2924 if (n < 0 || n > ada_array_arity (type)) 2925 error (_("invalid dimension number to '%s"), name); 2926 2927 if (ada_is_simple_array_type (type)) 2928 { 2929 int i; 2930 2931 for (i = 1; i < n; i += 1) 2932 type = TYPE_TARGET_TYPE (type); 2933 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type)); 2934 /* FIXME: The stabs type r(0,0);bound;bound in an array type 2935 has a target type of TYPE_CODE_UNDEF. We compensate here, but 2936 perhaps stabsread.c would make more sense. */ 2937 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF) 2938 result_type = NULL; 2939 } 2940 else 2941 { 2942 result_type = desc_index_type (desc_bounds_type (type), n); 2943 if (result_type == NULL) 2944 error (_("attempt to take bound of something that is not an array")); 2945 } 2946 2947 return result_type; 2948} 2949 2950/* Given that arr is an array type, returns the lower bound of the 2951 Nth index (numbering from 1) if WHICH is 0, and the upper bound if 2952 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an 2953 array-descriptor type. It works for other arrays with bounds supplied 2954 by run-time quantities other than discriminants. */ 2955 2956static LONGEST 2957ada_array_bound_from_type (struct type *arr_type, int n, int which) 2958{ 2959 struct type *type, *index_type_desc, *index_type; 2960 int i; 2961 2962 gdb_assert (which == 0 || which == 1); 2963 2964 if (ada_is_constrained_packed_array_type (arr_type)) 2965 arr_type = decode_constrained_packed_array_type (arr_type); 2966 2967 if (arr_type == NULL || !ada_is_simple_array_type (arr_type)) 2968 return (LONGEST) - which; 2969 2970 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR) 2971 type = TYPE_TARGET_TYPE (arr_type); 2972 else 2973 type = arr_type; 2974 2975 if (TYPE_FIXED_INSTANCE (type)) 2976 { 2977 /* The array has already been fixed, so we do not need to 2978 check the parallel ___XA type again. That encoding has 2979 already been applied, so ignore it now. */ 2980 index_type_desc = NULL; 2981 } 2982 else 2983 { 2984 index_type_desc = ada_find_parallel_type (type, "___XA"); 2985 ada_fixup_array_indexes_type (index_type_desc); 2986 } 2987 2988 if (index_type_desc != NULL) 2989 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1), 2990 NULL); 2991 else 2992 { 2993 struct type *elt_type = check_typedef (type); 2994 2995 for (i = 1; i < n; i++) 2996 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type)); 2997 2998 index_type = TYPE_INDEX_TYPE (elt_type); 2999 } 3000 3001 return 3002 (LONGEST) (which == 0 3003 ? ada_discrete_type_low_bound (index_type) 3004 : ada_discrete_type_high_bound (index_type)); 3005} 3006 3007/* Given that arr is an array value, returns the lower bound of the 3008 nth index (numbering from 1) if WHICH is 0, and the upper bound if 3009 WHICH is 1. This routine will also work for arrays with bounds 3010 supplied by run-time quantities other than discriminants. */ 3011 3012static LONGEST 3013ada_array_bound (struct value *arr, int n, int which) 3014{ 3015 struct type *arr_type; 3016 3017 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR) 3018 arr = value_ind (arr); 3019 arr_type = value_enclosing_type (arr); 3020 3021 if (ada_is_constrained_packed_array_type (arr_type)) 3022 return ada_array_bound (decode_constrained_packed_array (arr), n, which); 3023 else if (ada_is_simple_array_type (arr_type)) 3024 return ada_array_bound_from_type (arr_type, n, which); 3025 else 3026 return value_as_long (desc_one_bound (desc_bounds (arr), n, which)); 3027} 3028 3029/* Given that arr is an array value, returns the length of the 3030 nth index. This routine will also work for arrays with bounds 3031 supplied by run-time quantities other than discriminants. 3032 Does not work for arrays indexed by enumeration types with representation 3033 clauses at the moment. */ 3034 3035static LONGEST 3036ada_array_length (struct value *arr, int n) 3037{ 3038 struct type *arr_type, *index_type; 3039 int low, high; 3040 3041 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR) 3042 arr = value_ind (arr); 3043 arr_type = value_enclosing_type (arr); 3044 3045 if (ada_is_constrained_packed_array_type (arr_type)) 3046 return ada_array_length (decode_constrained_packed_array (arr), n); 3047 3048 if (ada_is_simple_array_type (arr_type)) 3049 { 3050 low = ada_array_bound_from_type (arr_type, n, 0); 3051 high = ada_array_bound_from_type (arr_type, n, 1); 3052 } 3053 else 3054 { 3055 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0)); 3056 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1)); 3057 } 3058 3059 CHECK_TYPEDEF (arr_type); 3060 index_type = TYPE_INDEX_TYPE (arr_type); 3061 if (index_type != NULL) 3062 { 3063 struct type *base_type; 3064 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE) 3065 base_type = TYPE_TARGET_TYPE (index_type); 3066 else 3067 base_type = index_type; 3068 3069 low = pos_atr (value_from_longest (base_type, low)); 3070 high = pos_atr (value_from_longest (base_type, high)); 3071 } 3072 return high - low + 1; 3073} 3074 3075/* An empty array whose type is that of ARR_TYPE (an array type), 3076 with bounds LOW to LOW-1. */ 3077 3078static struct value * 3079empty_array (struct type *arr_type, int low) 3080{ 3081 struct type *arr_type0 = ada_check_typedef (arr_type); 3082 struct type *index_type 3083 = create_static_range_type 3084 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1); 3085 struct type *elt_type = ada_array_element_type (arr_type0, 1); 3086 3087 return allocate_value (create_array_type (NULL, elt_type, index_type)); 3088} 3089 3090 3091 /* Name resolution */ 3092 3093/* The "decoded" name for the user-definable Ada operator corresponding 3094 to OP. */ 3095 3096static const char * 3097ada_decoded_op_name (enum exp_opcode op) 3098{ 3099 int i; 3100 3101 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1) 3102 { 3103 if (ada_opname_table[i].op == op) 3104 return ada_opname_table[i].decoded; 3105 } 3106 error (_("Could not find operator name for opcode")); 3107} 3108 3109 3110/* Same as evaluate_type (*EXP), but resolves ambiguous symbol 3111 references (marked by OP_VAR_VALUE nodes in which the symbol has an 3112 undefined namespace) and converts operators that are 3113 user-defined into appropriate function calls. If CONTEXT_TYPE is 3114 non-null, it provides a preferred result type [at the moment, only 3115 type void has any effect---causing procedures to be preferred over 3116 functions in calls]. A null CONTEXT_TYPE indicates that a non-void 3117 return type is preferred. May change (expand) *EXP. */ 3118 3119static void 3120resolve (struct expression **expp, int void_context_p) 3121{ 3122 struct type *context_type = NULL; 3123 int pc = 0; 3124 3125 if (void_context_p) 3126 context_type = builtin_type ((*expp)->gdbarch)->builtin_void; 3127 3128 resolve_subexp (expp, &pc, 1, context_type); 3129} 3130 3131/* Resolve the operator of the subexpression beginning at 3132 position *POS of *EXPP. "Resolving" consists of replacing 3133 the symbols that have undefined namespaces in OP_VAR_VALUE nodes 3134 with their resolutions, replacing built-in operators with 3135 function calls to user-defined operators, where appropriate, and, 3136 when DEPROCEDURE_P is non-zero, converting function-valued variables 3137 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions 3138 are as in ada_resolve, above. */ 3139 3140static struct value * 3141resolve_subexp (struct expression **expp, int *pos, int deprocedure_p, 3142 struct type *context_type) 3143{ 3144 int pc = *pos; 3145 int i; 3146 struct expression *exp; /* Convenience: == *expp. */ 3147 enum exp_opcode op = (*expp)->elts[pc].opcode; 3148 struct value **argvec; /* Vector of operand types (alloca'ed). */ 3149 int nargs; /* Number of operands. */ 3150 int oplen; 3151 3152 argvec = NULL; 3153 nargs = 0; 3154 exp = *expp; 3155 3156 /* Pass one: resolve operands, saving their types and updating *pos, 3157 if needed. */ 3158 switch (op) 3159 { 3160 case OP_FUNCALL: 3161 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE 3162 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 3163 *pos += 7; 3164 else 3165 { 3166 *pos += 3; 3167 resolve_subexp (expp, pos, 0, NULL); 3168 } 3169 nargs = longest_to_int (exp->elts[pc + 1].longconst); 3170 break; 3171 3172 case UNOP_ADDR: 3173 *pos += 1; 3174 resolve_subexp (expp, pos, 0, NULL); 3175 break; 3176 3177 case UNOP_QUAL: 3178 *pos += 3; 3179 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type)); 3180 break; 3181 3182 case OP_ATR_MODULUS: 3183 case OP_ATR_SIZE: 3184 case OP_ATR_TAG: 3185 case OP_ATR_FIRST: 3186 case OP_ATR_LAST: 3187 case OP_ATR_LENGTH: 3188 case OP_ATR_POS: 3189 case OP_ATR_VAL: 3190 case OP_ATR_MIN: 3191 case OP_ATR_MAX: 3192 case TERNOP_IN_RANGE: 3193 case BINOP_IN_BOUNDS: 3194 case UNOP_IN_RANGE: 3195 case OP_AGGREGATE: 3196 case OP_OTHERS: 3197 case OP_CHOICES: 3198 case OP_POSITIONAL: 3199 case OP_DISCRETE_RANGE: 3200 case OP_NAME: 3201 ada_forward_operator_length (exp, pc, &oplen, &nargs); 3202 *pos += oplen; 3203 break; 3204 3205 case BINOP_ASSIGN: 3206 { 3207 struct value *arg1; 3208 3209 *pos += 1; 3210 arg1 = resolve_subexp (expp, pos, 0, NULL); 3211 if (arg1 == NULL) 3212 resolve_subexp (expp, pos, 1, NULL); 3213 else 3214 resolve_subexp (expp, pos, 1, value_type (arg1)); 3215 break; 3216 } 3217 3218 case UNOP_CAST: 3219 *pos += 3; 3220 nargs = 1; 3221 break; 3222 3223 case BINOP_ADD: 3224 case BINOP_SUB: 3225 case BINOP_MUL: 3226 case BINOP_DIV: 3227 case BINOP_REM: 3228 case BINOP_MOD: 3229 case BINOP_EXP: 3230 case BINOP_CONCAT: 3231 case BINOP_LOGICAL_AND: 3232 case BINOP_LOGICAL_OR: 3233 case BINOP_BITWISE_AND: 3234 case BINOP_BITWISE_IOR: 3235 case BINOP_BITWISE_XOR: 3236 3237 case BINOP_EQUAL: 3238 case BINOP_NOTEQUAL: 3239 case BINOP_LESS: 3240 case BINOP_GTR: 3241 case BINOP_LEQ: 3242 case BINOP_GEQ: 3243 3244 case BINOP_REPEAT: 3245 case BINOP_SUBSCRIPT: 3246 case BINOP_COMMA: 3247 *pos += 1; 3248 nargs = 2; 3249 break; 3250 3251 case UNOP_NEG: 3252 case UNOP_PLUS: 3253 case UNOP_LOGICAL_NOT: 3254 case UNOP_ABS: 3255 case UNOP_IND: 3256 *pos += 1; 3257 nargs = 1; 3258 break; 3259 3260 case OP_LONG: 3261 case OP_DOUBLE: 3262 case OP_VAR_VALUE: 3263 *pos += 4; 3264 break; 3265 3266 case OP_TYPE: 3267 case OP_BOOL: 3268 case OP_LAST: 3269 case OP_INTERNALVAR: 3270 *pos += 3; 3271 break; 3272 3273 case UNOP_MEMVAL: 3274 *pos += 3; 3275 nargs = 1; 3276 break; 3277 3278 case OP_REGISTER: 3279 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1); 3280 break; 3281 3282 case STRUCTOP_STRUCT: 3283 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1); 3284 nargs = 1; 3285 break; 3286 3287 case TERNOP_SLICE: 3288 *pos += 1; 3289 nargs = 3; 3290 break; 3291 3292 case OP_STRING: 3293 break; 3294 3295 default: 3296 error (_("Unexpected operator during name resolution")); 3297 } 3298 3299 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1)); 3300 for (i = 0; i < nargs; i += 1) 3301 argvec[i] = resolve_subexp (expp, pos, 1, NULL); 3302 argvec[i] = NULL; 3303 exp = *expp; 3304 3305 /* Pass two: perform any resolution on principal operator. */ 3306 switch (op) 3307 { 3308 default: 3309 break; 3310 3311 case OP_VAR_VALUE: 3312 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN) 3313 { 3314 struct ada_symbol_info *candidates; 3315 int n_candidates; 3316 3317 n_candidates = 3318 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME 3319 (exp->elts[pc + 2].symbol), 3320 exp->elts[pc + 1].block, VAR_DOMAIN, 3321 &candidates); 3322 3323 if (n_candidates > 1) 3324 { 3325 /* Types tend to get re-introduced locally, so if there 3326 are any local symbols that are not types, first filter 3327 out all types. */ 3328 int j; 3329 for (j = 0; j < n_candidates; j += 1) 3330 switch (SYMBOL_CLASS (candidates[j].sym)) 3331 { 3332 case LOC_REGISTER: 3333 case LOC_ARG: 3334 case LOC_REF_ARG: 3335 case LOC_REGPARM_ADDR: 3336 case LOC_LOCAL: 3337 case LOC_COMPUTED: 3338 goto FoundNonType; 3339 default: 3340 break; 3341 } 3342 FoundNonType: 3343 if (j < n_candidates) 3344 { 3345 j = 0; 3346 while (j < n_candidates) 3347 { 3348 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF) 3349 { 3350 candidates[j] = candidates[n_candidates - 1]; 3351 n_candidates -= 1; 3352 } 3353 else 3354 j += 1; 3355 } 3356 } 3357 } 3358 3359 if (n_candidates == 0) 3360 error (_("No definition found for %s"), 3361 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3362 else if (n_candidates == 1) 3363 i = 0; 3364 else if (deprocedure_p 3365 && !is_nonfunction (candidates, n_candidates)) 3366 { 3367 i = ada_resolve_function 3368 (candidates, n_candidates, NULL, 0, 3369 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol), 3370 context_type); 3371 if (i < 0) 3372 error (_("Could not find a match for %s"), 3373 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3374 } 3375 else 3376 { 3377 printf_filtered (_("Multiple matches for %s\n"), 3378 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 3379 user_select_syms (candidates, n_candidates, 1); 3380 i = 0; 3381 } 3382 3383 exp->elts[pc + 1].block = candidates[i].block; 3384 exp->elts[pc + 2].symbol = candidates[i].sym; 3385 if (innermost_block == NULL 3386 || contained_in (candidates[i].block, innermost_block)) 3387 innermost_block = candidates[i].block; 3388 } 3389 3390 if (deprocedure_p 3391 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol)) 3392 == TYPE_CODE_FUNC)) 3393 { 3394 replace_operator_with_call (expp, pc, 0, 0, 3395 exp->elts[pc + 2].symbol, 3396 exp->elts[pc + 1].block); 3397 exp = *expp; 3398 } 3399 break; 3400 3401 case OP_FUNCALL: 3402 { 3403 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE 3404 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 3405 { 3406 struct ada_symbol_info *candidates; 3407 int n_candidates; 3408 3409 n_candidates = 3410 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME 3411 (exp->elts[pc + 5].symbol), 3412 exp->elts[pc + 4].block, VAR_DOMAIN, 3413 &candidates); 3414 if (n_candidates == 1) 3415 i = 0; 3416 else 3417 { 3418 i = ada_resolve_function 3419 (candidates, n_candidates, 3420 argvec, nargs, 3421 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol), 3422 context_type); 3423 if (i < 0) 3424 error (_("Could not find a match for %s"), 3425 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol)); 3426 } 3427 3428 exp->elts[pc + 4].block = candidates[i].block; 3429 exp->elts[pc + 5].symbol = candidates[i].sym; 3430 if (innermost_block == NULL 3431 || contained_in (candidates[i].block, innermost_block)) 3432 innermost_block = candidates[i].block; 3433 } 3434 } 3435 break; 3436 case BINOP_ADD: 3437 case BINOP_SUB: 3438 case BINOP_MUL: 3439 case BINOP_DIV: 3440 case BINOP_REM: 3441 case BINOP_MOD: 3442 case BINOP_CONCAT: 3443 case BINOP_BITWISE_AND: 3444 case BINOP_BITWISE_IOR: 3445 case BINOP_BITWISE_XOR: 3446 case BINOP_EQUAL: 3447 case BINOP_NOTEQUAL: 3448 case BINOP_LESS: 3449 case BINOP_GTR: 3450 case BINOP_LEQ: 3451 case BINOP_GEQ: 3452 case BINOP_EXP: 3453 case UNOP_NEG: 3454 case UNOP_PLUS: 3455 case UNOP_LOGICAL_NOT: 3456 case UNOP_ABS: 3457 if (possible_user_operator_p (op, argvec)) 3458 { 3459 struct ada_symbol_info *candidates; 3460 int n_candidates; 3461 3462 n_candidates = 3463 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)), 3464 (struct block *) NULL, VAR_DOMAIN, 3465 &candidates); 3466 i = ada_resolve_function (candidates, n_candidates, argvec, nargs, 3467 ada_decoded_op_name (op), NULL); 3468 if (i < 0) 3469 break; 3470 3471 replace_operator_with_call (expp, pc, nargs, 1, 3472 candidates[i].sym, candidates[i].block); 3473 exp = *expp; 3474 } 3475 break; 3476 3477 case OP_TYPE: 3478 case OP_REGISTER: 3479 return NULL; 3480 } 3481 3482 *pos = pc; 3483 return evaluate_subexp_type (exp, pos); 3484} 3485 3486/* Return non-zero if formal type FTYPE matches actual type ATYPE. If 3487 MAY_DEREF is non-zero, the formal may be a pointer and the actual 3488 a non-pointer. */ 3489/* The term "match" here is rather loose. The match is heuristic and 3490 liberal. */ 3491 3492static int 3493ada_type_match (struct type *ftype, struct type *atype, int may_deref) 3494{ 3495 ftype = ada_check_typedef (ftype); 3496 atype = ada_check_typedef (atype); 3497 3498 if (TYPE_CODE (ftype) == TYPE_CODE_REF) 3499 ftype = TYPE_TARGET_TYPE (ftype); 3500 if (TYPE_CODE (atype) == TYPE_CODE_REF) 3501 atype = TYPE_TARGET_TYPE (atype); 3502 3503 switch (TYPE_CODE (ftype)) 3504 { 3505 default: 3506 return TYPE_CODE (ftype) == TYPE_CODE (atype); 3507 case TYPE_CODE_PTR: 3508 if (TYPE_CODE (atype) == TYPE_CODE_PTR) 3509 return ada_type_match (TYPE_TARGET_TYPE (ftype), 3510 TYPE_TARGET_TYPE (atype), 0); 3511 else 3512 return (may_deref 3513 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0)); 3514 case TYPE_CODE_INT: 3515 case TYPE_CODE_ENUM: 3516 case TYPE_CODE_RANGE: 3517 switch (TYPE_CODE (atype)) 3518 { 3519 case TYPE_CODE_INT: 3520 case TYPE_CODE_ENUM: 3521 case TYPE_CODE_RANGE: 3522 return 1; 3523 default: 3524 return 0; 3525 } 3526 3527 case TYPE_CODE_ARRAY: 3528 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY 3529 || ada_is_array_descriptor_type (atype)); 3530 3531 case TYPE_CODE_STRUCT: 3532 if (ada_is_array_descriptor_type (ftype)) 3533 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY 3534 || ada_is_array_descriptor_type (atype)); 3535 else 3536 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT 3537 && !ada_is_array_descriptor_type (atype)); 3538 3539 case TYPE_CODE_UNION: 3540 case TYPE_CODE_FLT: 3541 return (TYPE_CODE (atype) == TYPE_CODE (ftype)); 3542 } 3543} 3544 3545/* Return non-zero if the formals of FUNC "sufficiently match" the 3546 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC 3547 may also be an enumeral, in which case it is treated as a 0- 3548 argument function. */ 3549 3550static int 3551ada_args_match (struct symbol *func, struct value **actuals, int n_actuals) 3552{ 3553 int i; 3554 struct type *func_type = SYMBOL_TYPE (func); 3555 3556 if (SYMBOL_CLASS (func) == LOC_CONST 3557 && TYPE_CODE (func_type) == TYPE_CODE_ENUM) 3558 return (n_actuals == 0); 3559 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC) 3560 return 0; 3561 3562 if (TYPE_NFIELDS (func_type) != n_actuals) 3563 return 0; 3564 3565 for (i = 0; i < n_actuals; i += 1) 3566 { 3567 if (actuals[i] == NULL) 3568 return 0; 3569 else 3570 { 3571 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type, 3572 i)); 3573 struct type *atype = ada_check_typedef (value_type (actuals[i])); 3574 3575 if (!ada_type_match (ftype, atype, 1)) 3576 return 0; 3577 } 3578 } 3579 return 1; 3580} 3581 3582/* False iff function type FUNC_TYPE definitely does not produce a value 3583 compatible with type CONTEXT_TYPE. Conservatively returns 1 if 3584 FUNC_TYPE is not a valid function type with a non-null return type 3585 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */ 3586 3587static int 3588return_match (struct type *func_type, struct type *context_type) 3589{ 3590 struct type *return_type; 3591 3592 if (func_type == NULL) 3593 return 1; 3594 3595 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC) 3596 return_type = get_base_type (TYPE_TARGET_TYPE (func_type)); 3597 else 3598 return_type = get_base_type (func_type); 3599 if (return_type == NULL) 3600 return 1; 3601 3602 context_type = get_base_type (context_type); 3603 3604 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM) 3605 return context_type == NULL || return_type == context_type; 3606 else if (context_type == NULL) 3607 return TYPE_CODE (return_type) != TYPE_CODE_VOID; 3608 else 3609 return TYPE_CODE (return_type) == TYPE_CODE (context_type); 3610} 3611 3612 3613/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the 3614 function (if any) that matches the types of the NARGS arguments in 3615 ARGS. If CONTEXT_TYPE is non-null and there is at least one match 3616 that returns that type, then eliminate matches that don't. If 3617 CONTEXT_TYPE is void and there is at least one match that does not 3618 return void, eliminate all matches that do. 3619 3620 Asks the user if there is more than one match remaining. Returns -1 3621 if there is no such symbol or none is selected. NAME is used 3622 solely for messages. May re-arrange and modify SYMS in 3623 the process; the index returned is for the modified vector. */ 3624 3625static int 3626ada_resolve_function (struct ada_symbol_info syms[], 3627 int nsyms, struct value **args, int nargs, 3628 const char *name, struct type *context_type) 3629{ 3630 int fallback; 3631 int k; 3632 int m; /* Number of hits */ 3633 3634 m = 0; 3635 /* In the first pass of the loop, we only accept functions matching 3636 context_type. If none are found, we add a second pass of the loop 3637 where every function is accepted. */ 3638 for (fallback = 0; m == 0 && fallback < 2; fallback++) 3639 { 3640 for (k = 0; k < nsyms; k += 1) 3641 { 3642 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym)); 3643 3644 if (ada_args_match (syms[k].sym, args, nargs) 3645 && (fallback || return_match (type, context_type))) 3646 { 3647 syms[m] = syms[k]; 3648 m += 1; 3649 } 3650 } 3651 } 3652 3653 if (m == 0) 3654 return -1; 3655 else if (m > 1) 3656 { 3657 printf_filtered (_("Multiple matches for %s\n"), name); 3658 user_select_syms (syms, m, 1); 3659 return 0; 3660 } 3661 return 0; 3662} 3663 3664/* Returns true (non-zero) iff decoded name N0 should appear before N1 3665 in a listing of choices during disambiguation (see sort_choices, below). 3666 The idea is that overloadings of a subprogram name from the 3667 same package should sort in their source order. We settle for ordering 3668 such symbols by their trailing number (__N or $N). */ 3669 3670static int 3671encoded_ordered_before (const char *N0, const char *N1) 3672{ 3673 if (N1 == NULL) 3674 return 0; 3675 else if (N0 == NULL) 3676 return 1; 3677 else 3678 { 3679 int k0, k1; 3680 3681 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1) 3682 ; 3683 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1) 3684 ; 3685 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000' 3686 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000') 3687 { 3688 int n0, n1; 3689 3690 n0 = k0; 3691 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_') 3692 n0 -= 1; 3693 n1 = k1; 3694 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_') 3695 n1 -= 1; 3696 if (n0 == n1 && strncmp (N0, N1, n0) == 0) 3697 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1)); 3698 } 3699 return (strcmp (N0, N1) < 0); 3700 } 3701} 3702 3703/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the 3704 encoded names. */ 3705 3706static void 3707sort_choices (struct ada_symbol_info syms[], int nsyms) 3708{ 3709 int i; 3710 3711 for (i = 1; i < nsyms; i += 1) 3712 { 3713 struct ada_symbol_info sym = syms[i]; 3714 int j; 3715 3716 for (j = i - 1; j >= 0; j -= 1) 3717 { 3718 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym), 3719 SYMBOL_LINKAGE_NAME (sym.sym))) 3720 break; 3721 syms[j + 1] = syms[j]; 3722 } 3723 syms[j + 1] = sym; 3724 } 3725} 3726 3727/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0 3728 by asking the user (if necessary), returning the number selected, 3729 and setting the first elements of SYMS items. Error if no symbols 3730 selected. */ 3731 3732/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought 3733 to be re-integrated one of these days. */ 3734 3735int 3736user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results) 3737{ 3738 int i; 3739 int *chosen = (int *) alloca (sizeof (int) * nsyms); 3740 int n_chosen; 3741 int first_choice = (max_results == 1) ? 1 : 2; 3742 const char *select_mode = multiple_symbols_select_mode (); 3743 3744 if (max_results < 1) 3745 error (_("Request to select 0 symbols!")); 3746 if (nsyms <= 1) 3747 return nsyms; 3748 3749 if (select_mode == multiple_symbols_cancel) 3750 error (_("\ 3751canceled because the command is ambiguous\n\ 3752See set/show multiple-symbol.")); 3753 3754 /* If select_mode is "all", then return all possible symbols. 3755 Only do that if more than one symbol can be selected, of course. 3756 Otherwise, display the menu as usual. */ 3757 if (select_mode == multiple_symbols_all && max_results > 1) 3758 return nsyms; 3759 3760 printf_unfiltered (_("[0] cancel\n")); 3761 if (max_results > 1) 3762 printf_unfiltered (_("[1] all\n")); 3763 3764 sort_choices (syms, nsyms); 3765 3766 for (i = 0; i < nsyms; i += 1) 3767 { 3768 if (syms[i].sym == NULL) 3769 continue; 3770 3771 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK) 3772 { 3773 struct symtab_and_line sal = 3774 find_function_start_sal (syms[i].sym, 1); 3775 3776 if (sal.symtab == NULL) 3777 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"), 3778 i + first_choice, 3779 SYMBOL_PRINT_NAME (syms[i].sym), 3780 sal.line); 3781 else 3782 printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice, 3783 SYMBOL_PRINT_NAME (syms[i].sym), 3784 symtab_to_filename_for_display (sal.symtab), 3785 sal.line); 3786 continue; 3787 } 3788 else 3789 { 3790 int is_enumeral = 3791 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST 3792 && SYMBOL_TYPE (syms[i].sym) != NULL 3793 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM); 3794 struct symtab *symtab = NULL; 3795 3796 if (SYMBOL_OBJFILE_OWNED (syms[i].sym)) 3797 symtab = symbol_symtab (syms[i].sym); 3798 3799 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL) 3800 printf_unfiltered (_("[%d] %s at %s:%d\n"), 3801 i + first_choice, 3802 SYMBOL_PRINT_NAME (syms[i].sym), 3803 symtab_to_filename_for_display (symtab), 3804 SYMBOL_LINE (syms[i].sym)); 3805 else if (is_enumeral 3806 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL) 3807 { 3808 printf_unfiltered (("[%d] "), i + first_choice); 3809 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL, 3810 gdb_stdout, -1, 0, &type_print_raw_options); 3811 printf_unfiltered (_("'(%s) (enumeral)\n"), 3812 SYMBOL_PRINT_NAME (syms[i].sym)); 3813 } 3814 else if (symtab != NULL) 3815 printf_unfiltered (is_enumeral 3816 ? _("[%d] %s in %s (enumeral)\n") 3817 : _("[%d] %s at %s:?\n"), 3818 i + first_choice, 3819 SYMBOL_PRINT_NAME (syms[i].sym), 3820 symtab_to_filename_for_display (symtab)); 3821 else 3822 printf_unfiltered (is_enumeral 3823 ? _("[%d] %s (enumeral)\n") 3824 : _("[%d] %s at ?\n"), 3825 i + first_choice, 3826 SYMBOL_PRINT_NAME (syms[i].sym)); 3827 } 3828 } 3829 3830 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1, 3831 "overload-choice"); 3832 3833 for (i = 0; i < n_chosen; i += 1) 3834 syms[i] = syms[chosen[i]]; 3835 3836 return n_chosen; 3837} 3838 3839/* Read and validate a set of numeric choices from the user in the 3840 range 0 .. N_CHOICES-1. Place the results in increasing 3841 order in CHOICES[0 .. N-1], and return N. 3842 3843 The user types choices as a sequence of numbers on one line 3844 separated by blanks, encoding them as follows: 3845 3846 + A choice of 0 means to cancel the selection, throwing an error. 3847 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1. 3848 + The user chooses k by typing k+IS_ALL_CHOICE+1. 3849 3850 The user is not allowed to choose more than MAX_RESULTS values. 3851 3852 ANNOTATION_SUFFIX, if present, is used to annotate the input 3853 prompts (for use with the -f switch). */ 3854 3855int 3856get_selections (int *choices, int n_choices, int max_results, 3857 int is_all_choice, char *annotation_suffix) 3858{ 3859 char *args; 3860 char *prompt; 3861 int n_chosen; 3862 int first_choice = is_all_choice ? 2 : 1; 3863 3864 prompt = getenv ("PS2"); 3865 if (prompt == NULL) 3866 prompt = "> "; 3867 3868 args = command_line_input (prompt, 0, annotation_suffix); 3869 3870 if (args == NULL) 3871 error_no_arg (_("one or more choice numbers")); 3872 3873 n_chosen = 0; 3874 3875 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending 3876 order, as given in args. Choices are validated. */ 3877 while (1) 3878 { 3879 char *args2; 3880 int choice, j; 3881 3882 args = skip_spaces (args); 3883 if (*args == '\0' && n_chosen == 0) 3884 error_no_arg (_("one or more choice numbers")); 3885 else if (*args == '\0') 3886 break; 3887 3888 choice = strtol (args, &args2, 10); 3889 if (args == args2 || choice < 0 3890 || choice > n_choices + first_choice - 1) 3891 error (_("Argument must be choice number")); 3892 args = args2; 3893 3894 if (choice == 0) 3895 error (_("cancelled")); 3896 3897 if (choice < first_choice) 3898 { 3899 n_chosen = n_choices; 3900 for (j = 0; j < n_choices; j += 1) 3901 choices[j] = j; 3902 break; 3903 } 3904 choice -= first_choice; 3905 3906 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1) 3907 { 3908 } 3909 3910 if (j < 0 || choice != choices[j]) 3911 { 3912 int k; 3913 3914 for (k = n_chosen - 1; k > j; k -= 1) 3915 choices[k + 1] = choices[k]; 3916 choices[j + 1] = choice; 3917 n_chosen += 1; 3918 } 3919 } 3920 3921 if (n_chosen > max_results) 3922 error (_("Select no more than %d of the above"), max_results); 3923 3924 return n_chosen; 3925} 3926 3927/* Replace the operator of length OPLEN at position PC in *EXPP with a call 3928 on the function identified by SYM and BLOCK, and taking NARGS 3929 arguments. Update *EXPP as needed to hold more space. */ 3930 3931static void 3932replace_operator_with_call (struct expression **expp, int pc, int nargs, 3933 int oplen, struct symbol *sym, 3934 const struct block *block) 3935{ 3936 /* A new expression, with 6 more elements (3 for funcall, 4 for function 3937 symbol, -oplen for operator being replaced). */ 3938 struct expression *newexp = (struct expression *) 3939 xzalloc (sizeof (struct expression) 3940 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen)); 3941 struct expression *exp = *expp; 3942 3943 newexp->nelts = exp->nelts + 7 - oplen; 3944 newexp->language_defn = exp->language_defn; 3945 newexp->gdbarch = exp->gdbarch; 3946 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc)); 3947 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen, 3948 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen)); 3949 3950 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL; 3951 newexp->elts[pc + 1].longconst = (LONGEST) nargs; 3952 3953 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE; 3954 newexp->elts[pc + 4].block = block; 3955 newexp->elts[pc + 5].symbol = sym; 3956 3957 *expp = newexp; 3958 xfree (exp); 3959} 3960 3961/* Type-class predicates */ 3962 3963/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), 3964 or FLOAT). */ 3965 3966static int 3967numeric_type_p (struct type *type) 3968{ 3969 if (type == NULL) 3970 return 0; 3971 else 3972 { 3973 switch (TYPE_CODE (type)) 3974 { 3975 case TYPE_CODE_INT: 3976 case TYPE_CODE_FLT: 3977 return 1; 3978 case TYPE_CODE_RANGE: 3979 return (type == TYPE_TARGET_TYPE (type) 3980 || numeric_type_p (TYPE_TARGET_TYPE (type))); 3981 default: 3982 return 0; 3983 } 3984 } 3985} 3986 3987/* True iff TYPE is integral (an INT or RANGE of INTs). */ 3988 3989static int 3990integer_type_p (struct type *type) 3991{ 3992 if (type == NULL) 3993 return 0; 3994 else 3995 { 3996 switch (TYPE_CODE (type)) 3997 { 3998 case TYPE_CODE_INT: 3999 return 1; 4000 case TYPE_CODE_RANGE: 4001 return (type == TYPE_TARGET_TYPE (type) 4002 || integer_type_p (TYPE_TARGET_TYPE (type))); 4003 default: 4004 return 0; 4005 } 4006 } 4007} 4008 4009/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */ 4010 4011static int 4012scalar_type_p (struct type *type) 4013{ 4014 if (type == NULL) 4015 return 0; 4016 else 4017 { 4018 switch (TYPE_CODE (type)) 4019 { 4020 case TYPE_CODE_INT: 4021 case TYPE_CODE_RANGE: 4022 case TYPE_CODE_ENUM: 4023 case TYPE_CODE_FLT: 4024 return 1; 4025 default: 4026 return 0; 4027 } 4028 } 4029} 4030 4031/* True iff TYPE is discrete (INT, RANGE, ENUM). */ 4032 4033static int 4034discrete_type_p (struct type *type) 4035{ 4036 if (type == NULL) 4037 return 0; 4038 else 4039 { 4040 switch (TYPE_CODE (type)) 4041 { 4042 case TYPE_CODE_INT: 4043 case TYPE_CODE_RANGE: 4044 case TYPE_CODE_ENUM: 4045 case TYPE_CODE_BOOL: 4046 return 1; 4047 default: 4048 return 0; 4049 } 4050 } 4051} 4052 4053/* Returns non-zero if OP with operands in the vector ARGS could be 4054 a user-defined function. Errs on the side of pre-defined operators 4055 (i.e., result 0). */ 4056 4057static int 4058possible_user_operator_p (enum exp_opcode op, struct value *args[]) 4059{ 4060 struct type *type0 = 4061 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0])); 4062 struct type *type1 = 4063 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1])); 4064 4065 if (type0 == NULL) 4066 return 0; 4067 4068 switch (op) 4069 { 4070 default: 4071 return 0; 4072 4073 case BINOP_ADD: 4074 case BINOP_SUB: 4075 case BINOP_MUL: 4076 case BINOP_DIV: 4077 return (!(numeric_type_p (type0) && numeric_type_p (type1))); 4078 4079 case BINOP_REM: 4080 case BINOP_MOD: 4081 case BINOP_BITWISE_AND: 4082 case BINOP_BITWISE_IOR: 4083 case BINOP_BITWISE_XOR: 4084 return (!(integer_type_p (type0) && integer_type_p (type1))); 4085 4086 case BINOP_EQUAL: 4087 case BINOP_NOTEQUAL: 4088 case BINOP_LESS: 4089 case BINOP_GTR: 4090 case BINOP_LEQ: 4091 case BINOP_GEQ: 4092 return (!(scalar_type_p (type0) && scalar_type_p (type1))); 4093 4094 case BINOP_CONCAT: 4095 return !ada_is_array_type (type0) || !ada_is_array_type (type1); 4096 4097 case BINOP_EXP: 4098 return (!(numeric_type_p (type0) && integer_type_p (type1))); 4099 4100 case UNOP_NEG: 4101 case UNOP_PLUS: 4102 case UNOP_LOGICAL_NOT: 4103 case UNOP_ABS: 4104 return (!numeric_type_p (type0)); 4105 4106 } 4107} 4108 4109 /* Renaming */ 4110 4111/* NOTES: 4112 4113 1. In the following, we assume that a renaming type's name may 4114 have an ___XD suffix. It would be nice if this went away at some 4115 point. 4116 2. We handle both the (old) purely type-based representation of 4117 renamings and the (new) variable-based encoding. At some point, 4118 it is devoutly to be hoped that the former goes away 4119 (FIXME: hilfinger-2007-07-09). 4120 3. Subprogram renamings are not implemented, although the XRS 4121 suffix is recognized (FIXME: hilfinger-2007-07-09). */ 4122 4123/* If SYM encodes a renaming, 4124 4125 <renaming> renames <renamed entity>, 4126 4127 sets *LEN to the length of the renamed entity's name, 4128 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to 4129 the string describing the subcomponent selected from the renamed 4130 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming 4131 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR 4132 are undefined). Otherwise, returns a value indicating the category 4133 of entity renamed: an object (ADA_OBJECT_RENAMING), exception 4134 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or 4135 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the 4136 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be 4137 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR 4138 may be NULL, in which case they are not assigned. 4139 4140 [Currently, however, GCC does not generate subprogram renamings.] */ 4141 4142enum ada_renaming_category 4143ada_parse_renaming (struct symbol *sym, 4144 const char **renamed_entity, int *len, 4145 const char **renaming_expr) 4146{ 4147 enum ada_renaming_category kind; 4148 const char *info; 4149 const char *suffix; 4150 4151 if (sym == NULL) 4152 return ADA_NOT_RENAMING; 4153 switch (SYMBOL_CLASS (sym)) 4154 { 4155 default: 4156 return ADA_NOT_RENAMING; 4157 case LOC_TYPEDEF: 4158 return parse_old_style_renaming (SYMBOL_TYPE (sym), 4159 renamed_entity, len, renaming_expr); 4160 case LOC_LOCAL: 4161 case LOC_STATIC: 4162 case LOC_COMPUTED: 4163 case LOC_OPTIMIZED_OUT: 4164 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR"); 4165 if (info == NULL) 4166 return ADA_NOT_RENAMING; 4167 switch (info[5]) 4168 { 4169 case '_': 4170 kind = ADA_OBJECT_RENAMING; 4171 info += 6; 4172 break; 4173 case 'E': 4174 kind = ADA_EXCEPTION_RENAMING; 4175 info += 7; 4176 break; 4177 case 'P': 4178 kind = ADA_PACKAGE_RENAMING; 4179 info += 7; 4180 break; 4181 case 'S': 4182 kind = ADA_SUBPROGRAM_RENAMING; 4183 info += 7; 4184 break; 4185 default: 4186 return ADA_NOT_RENAMING; 4187 } 4188 } 4189 4190 if (renamed_entity != NULL) 4191 *renamed_entity = info; 4192 suffix = strstr (info, "___XE"); 4193 if (suffix == NULL || suffix == info) 4194 return ADA_NOT_RENAMING; 4195 if (len != NULL) 4196 *len = strlen (info) - strlen (suffix); 4197 suffix += 5; 4198 if (renaming_expr != NULL) 4199 *renaming_expr = suffix; 4200 return kind; 4201} 4202 4203/* Assuming TYPE encodes a renaming according to the old encoding in 4204 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY, 4205 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns 4206 ADA_NOT_RENAMING otherwise. */ 4207static enum ada_renaming_category 4208parse_old_style_renaming (struct type *type, 4209 const char **renamed_entity, int *len, 4210 const char **renaming_expr) 4211{ 4212 enum ada_renaming_category kind; 4213 const char *name; 4214 const char *info; 4215 const char *suffix; 4216 4217 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM 4218 || TYPE_NFIELDS (type) != 1) 4219 return ADA_NOT_RENAMING; 4220 4221 name = type_name_no_tag (type); 4222 if (name == NULL) 4223 return ADA_NOT_RENAMING; 4224 4225 name = strstr (name, "___XR"); 4226 if (name == NULL) 4227 return ADA_NOT_RENAMING; 4228 switch (name[5]) 4229 { 4230 case '\0': 4231 case '_': 4232 kind = ADA_OBJECT_RENAMING; 4233 break; 4234 case 'E': 4235 kind = ADA_EXCEPTION_RENAMING; 4236 break; 4237 case 'P': 4238 kind = ADA_PACKAGE_RENAMING; 4239 break; 4240 case 'S': 4241 kind = ADA_SUBPROGRAM_RENAMING; 4242 break; 4243 default: 4244 return ADA_NOT_RENAMING; 4245 } 4246 4247 info = TYPE_FIELD_NAME (type, 0); 4248 if (info == NULL) 4249 return ADA_NOT_RENAMING; 4250 if (renamed_entity != NULL) 4251 *renamed_entity = info; 4252 suffix = strstr (info, "___XE"); 4253 if (renaming_expr != NULL) 4254 *renaming_expr = suffix + 5; 4255 if (suffix == NULL || suffix == info) 4256 return ADA_NOT_RENAMING; 4257 if (len != NULL) 4258 *len = suffix - info; 4259 return kind; 4260} 4261 4262/* Compute the value of the given RENAMING_SYM, which is expected to 4263 be a symbol encoding a renaming expression. BLOCK is the block 4264 used to evaluate the renaming. */ 4265 4266static struct value * 4267ada_read_renaming_var_value (struct symbol *renaming_sym, 4268 const struct block *block) 4269{ 4270 const char *sym_name; 4271 struct expression *expr; 4272 struct value *value; 4273 struct cleanup *old_chain = NULL; 4274 4275 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym); 4276 expr = parse_exp_1 (&sym_name, 0, block, 0); 4277 old_chain = make_cleanup (free_current_contents, &expr); 4278 value = evaluate_expression (expr); 4279 4280 do_cleanups (old_chain); 4281 return value; 4282} 4283 4284 4285 /* Evaluation: Function Calls */ 4286 4287/* Return an lvalue containing the value VAL. This is the identity on 4288 lvalues, and otherwise has the side-effect of allocating memory 4289 in the inferior where a copy of the value contents is copied. */ 4290 4291static struct value * 4292ensure_lval (struct value *val) 4293{ 4294 if (VALUE_LVAL (val) == not_lval 4295 || VALUE_LVAL (val) == lval_internalvar) 4296 { 4297 int len = TYPE_LENGTH (ada_check_typedef (value_type (val))); 4298 const CORE_ADDR addr = 4299 value_as_long (value_allocate_space_in_inferior (len)); 4300 4301 set_value_address (val, addr); 4302 VALUE_LVAL (val) = lval_memory; 4303 write_memory (addr, value_contents (val), len); 4304 } 4305 4306 return val; 4307} 4308 4309/* Return the value ACTUAL, converted to be an appropriate value for a 4310 formal of type FORMAL_TYPE. Use *SP as a stack pointer for 4311 allocating any necessary descriptors (fat pointers), or copies of 4312 values not residing in memory, updating it as needed. */ 4313 4314struct value * 4315ada_convert_actual (struct value *actual, struct type *formal_type0) 4316{ 4317 struct type *actual_type = ada_check_typedef (value_type (actual)); 4318 struct type *formal_type = ada_check_typedef (formal_type0); 4319 struct type *formal_target = 4320 TYPE_CODE (formal_type) == TYPE_CODE_PTR 4321 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type; 4322 struct type *actual_target = 4323 TYPE_CODE (actual_type) == TYPE_CODE_PTR 4324 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type; 4325 4326 if (ada_is_array_descriptor_type (formal_target) 4327 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY) 4328 return make_array_descriptor (formal_type, actual); 4329 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR 4330 || TYPE_CODE (formal_type) == TYPE_CODE_REF) 4331 { 4332 struct value *result; 4333 4334 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY 4335 && ada_is_array_descriptor_type (actual_target)) 4336 result = desc_data (actual); 4337 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR) 4338 { 4339 if (VALUE_LVAL (actual) != lval_memory) 4340 { 4341 struct value *val; 4342 4343 actual_type = ada_check_typedef (value_type (actual)); 4344 val = allocate_value (actual_type); 4345 memcpy ((char *) value_contents_raw (val), 4346 (char *) value_contents (actual), 4347 TYPE_LENGTH (actual_type)); 4348 actual = ensure_lval (val); 4349 } 4350 result = value_addr (actual); 4351 } 4352 else 4353 return actual; 4354 return value_cast_pointers (formal_type, result, 0); 4355 } 4356 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR) 4357 return ada_value_ind (actual); 4358 else if (ada_is_aligner_type (formal_type)) 4359 { 4360 /* We need to turn this parameter into an aligner type 4361 as well. */ 4362 struct value *aligner = allocate_value (formal_type); 4363 struct value *component = ada_value_struct_elt (aligner, "F", 0); 4364 4365 value_assign_to_component (aligner, component, actual); 4366 return aligner; 4367 } 4368 4369 return actual; 4370} 4371 4372/* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of 4373 type TYPE. This is usually an inefficient no-op except on some targets 4374 (such as AVR) where the representation of a pointer and an address 4375 differs. */ 4376 4377static CORE_ADDR 4378value_pointer (struct value *value, struct type *type) 4379{ 4380 struct gdbarch *gdbarch = get_type_arch (type); 4381 unsigned len = TYPE_LENGTH (type); 4382 gdb_byte *buf = alloca (len); 4383 CORE_ADDR addr; 4384 4385 addr = value_address (value); 4386 gdbarch_address_to_pointer (gdbarch, type, buf, addr); 4387 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch)); 4388 return addr; 4389} 4390 4391 4392/* Push a descriptor of type TYPE for array value ARR on the stack at 4393 *SP, updating *SP to reflect the new descriptor. Return either 4394 an lvalue representing the new descriptor, or (if TYPE is a pointer- 4395 to-descriptor type rather than a descriptor type), a struct value * 4396 representing a pointer to this descriptor. */ 4397 4398static struct value * 4399make_array_descriptor (struct type *type, struct value *arr) 4400{ 4401 struct type *bounds_type = desc_bounds_type (type); 4402 struct type *desc_type = desc_base_type (type); 4403 struct value *descriptor = allocate_value (desc_type); 4404 struct value *bounds = allocate_value (bounds_type); 4405 int i; 4406 4407 for (i = ada_array_arity (ada_check_typedef (value_type (arr))); 4408 i > 0; i -= 1) 4409 { 4410 modify_field (value_type (bounds), value_contents_writeable (bounds), 4411 ada_array_bound (arr, i, 0), 4412 desc_bound_bitpos (bounds_type, i, 0), 4413 desc_bound_bitsize (bounds_type, i, 0)); 4414 modify_field (value_type (bounds), value_contents_writeable (bounds), 4415 ada_array_bound (arr, i, 1), 4416 desc_bound_bitpos (bounds_type, i, 1), 4417 desc_bound_bitsize (bounds_type, i, 1)); 4418 } 4419 4420 bounds = ensure_lval (bounds); 4421 4422 modify_field (value_type (descriptor), 4423 value_contents_writeable (descriptor), 4424 value_pointer (ensure_lval (arr), 4425 TYPE_FIELD_TYPE (desc_type, 0)), 4426 fat_pntr_data_bitpos (desc_type), 4427 fat_pntr_data_bitsize (desc_type)); 4428 4429 modify_field (value_type (descriptor), 4430 value_contents_writeable (descriptor), 4431 value_pointer (bounds, 4432 TYPE_FIELD_TYPE (desc_type, 1)), 4433 fat_pntr_bounds_bitpos (desc_type), 4434 fat_pntr_bounds_bitsize (desc_type)); 4435 4436 descriptor = ensure_lval (descriptor); 4437 4438 if (TYPE_CODE (type) == TYPE_CODE_PTR) 4439 return value_addr (descriptor); 4440 else 4441 return descriptor; 4442} 4443 4444 /* Symbol Cache Module */ 4445 4446/* Performance measurements made as of 2010-01-15 indicate that 4447 this cache does bring some noticeable improvements. Depending 4448 on the type of entity being printed, the cache can make it as much 4449 as an order of magnitude faster than without it. 4450 4451 The descriptive type DWARF extension has significantly reduced 4452 the need for this cache, at least when DWARF is being used. However, 4453 even in this case, some expensive name-based symbol searches are still 4454 sometimes necessary - to find an XVZ variable, mostly. */ 4455 4456/* Initialize the contents of SYM_CACHE. */ 4457 4458static void 4459ada_init_symbol_cache (struct ada_symbol_cache *sym_cache) 4460{ 4461 obstack_init (&sym_cache->cache_space); 4462 memset (sym_cache->root, '\000', sizeof (sym_cache->root)); 4463} 4464 4465/* Free the memory used by SYM_CACHE. */ 4466 4467static void 4468ada_free_symbol_cache (struct ada_symbol_cache *sym_cache) 4469{ 4470 obstack_free (&sym_cache->cache_space, NULL); 4471 xfree (sym_cache); 4472} 4473 4474/* Return the symbol cache associated to the given program space PSPACE. 4475 If not allocated for this PSPACE yet, allocate and initialize one. */ 4476 4477static struct ada_symbol_cache * 4478ada_get_symbol_cache (struct program_space *pspace) 4479{ 4480 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace); 4481 4482 if (pspace_data->sym_cache == NULL) 4483 { 4484 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache); 4485 ada_init_symbol_cache (pspace_data->sym_cache); 4486 } 4487 4488 return pspace_data->sym_cache; 4489} 4490 4491/* Clear all entries from the symbol cache. */ 4492 4493static void 4494ada_clear_symbol_cache (void) 4495{ 4496 struct ada_symbol_cache *sym_cache 4497 = ada_get_symbol_cache (current_program_space); 4498 4499 obstack_free (&sym_cache->cache_space, NULL); 4500 ada_init_symbol_cache (sym_cache); 4501} 4502 4503/* Search our cache for an entry matching NAME and DOMAIN. 4504 Return it if found, or NULL otherwise. */ 4505 4506static struct cache_entry ** 4507find_entry (const char *name, domain_enum domain) 4508{ 4509 struct ada_symbol_cache *sym_cache 4510 = ada_get_symbol_cache (current_program_space); 4511 int h = msymbol_hash (name) % HASH_SIZE; 4512 struct cache_entry **e; 4513 4514 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next) 4515 { 4516 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0) 4517 return e; 4518 } 4519 return NULL; 4520} 4521 4522/* Search the symbol cache for an entry matching NAME and DOMAIN. 4523 Return 1 if found, 0 otherwise. 4524 4525 If an entry was found and SYM is not NULL, set *SYM to the entry's 4526 SYM. Same principle for BLOCK if not NULL. */ 4527 4528static int 4529lookup_cached_symbol (const char *name, domain_enum domain, 4530 struct symbol **sym, const struct block **block) 4531{ 4532 struct cache_entry **e = find_entry (name, domain); 4533 4534 if (e == NULL) 4535 return 0; 4536 if (sym != NULL) 4537 *sym = (*e)->sym; 4538 if (block != NULL) 4539 *block = (*e)->block; 4540 return 1; 4541} 4542 4543/* Assuming that (SYM, BLOCK) is the result of the lookup of NAME 4544 in domain DOMAIN, save this result in our symbol cache. */ 4545 4546static void 4547cache_symbol (const char *name, domain_enum domain, struct symbol *sym, 4548 const struct block *block) 4549{ 4550 struct ada_symbol_cache *sym_cache 4551 = ada_get_symbol_cache (current_program_space); 4552 int h; 4553 char *copy; 4554 struct cache_entry *e; 4555 4556 /* Symbols for builtin types don't have a block. 4557 For now don't cache such symbols. */ 4558 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym)) 4559 return; 4560 4561 /* If the symbol is a local symbol, then do not cache it, as a search 4562 for that symbol depends on the context. To determine whether 4563 the symbol is local or not, we check the block where we found it 4564 against the global and static blocks of its associated symtab. */ 4565 if (sym 4566 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)), 4567 GLOBAL_BLOCK) != block 4568 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)), 4569 STATIC_BLOCK) != block) 4570 return; 4571 4572 h = msymbol_hash (name) % HASH_SIZE; 4573 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space, 4574 sizeof (*e)); 4575 e->next = sym_cache->root[h]; 4576 sym_cache->root[h] = e; 4577 e->name = copy = obstack_alloc (&sym_cache->cache_space, strlen (name) + 1); 4578 strcpy (copy, name); 4579 e->sym = sym; 4580 e->domain = domain; 4581 e->block = block; 4582} 4583 4584 /* Symbol Lookup */ 4585 4586/* Return nonzero if wild matching should be used when searching for 4587 all symbols matching LOOKUP_NAME. 4588 4589 LOOKUP_NAME is expected to be a symbol name after transformation 4590 for Ada lookups (see ada_name_for_lookup). */ 4591 4592static int 4593should_use_wild_match (const char *lookup_name) 4594{ 4595 return (strstr (lookup_name, "__") == NULL); 4596} 4597 4598/* Return the result of a standard (literal, C-like) lookup of NAME in 4599 given DOMAIN, visible from lexical block BLOCK. */ 4600 4601static struct symbol * 4602standard_lookup (const char *name, const struct block *block, 4603 domain_enum domain) 4604{ 4605 /* Initialize it just to avoid a GCC false warning. */ 4606 struct symbol *sym = NULL; 4607 4608 if (lookup_cached_symbol (name, domain, &sym, NULL)) 4609 return sym; 4610 sym = lookup_symbol_in_language (name, block, domain, language_c, 0); 4611 cache_symbol (name, domain, sym, block_found); 4612 return sym; 4613} 4614 4615 4616/* Non-zero iff there is at least one non-function/non-enumeral symbol 4617 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions, 4618 since they contend in overloading in the same way. */ 4619static int 4620is_nonfunction (struct ada_symbol_info syms[], int n) 4621{ 4622 int i; 4623 4624 for (i = 0; i < n; i += 1) 4625 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC 4626 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM 4627 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST)) 4628 return 1; 4629 4630 return 0; 4631} 4632 4633/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent 4634 struct types. Otherwise, they may not. */ 4635 4636static int 4637equiv_types (struct type *type0, struct type *type1) 4638{ 4639 if (type0 == type1) 4640 return 1; 4641 if (type0 == NULL || type1 == NULL 4642 || TYPE_CODE (type0) != TYPE_CODE (type1)) 4643 return 0; 4644 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT 4645 || TYPE_CODE (type0) == TYPE_CODE_ENUM) 4646 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL 4647 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0) 4648 return 1; 4649 4650 return 0; 4651} 4652 4653/* True iff SYM0 represents the same entity as SYM1, or one that is 4654 no more defined than that of SYM1. */ 4655 4656static int 4657lesseq_defined_than (struct symbol *sym0, struct symbol *sym1) 4658{ 4659 if (sym0 == sym1) 4660 return 1; 4661 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1) 4662 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1)) 4663 return 0; 4664 4665 switch (SYMBOL_CLASS (sym0)) 4666 { 4667 case LOC_UNDEF: 4668 return 1; 4669 case LOC_TYPEDEF: 4670 { 4671 struct type *type0 = SYMBOL_TYPE (sym0); 4672 struct type *type1 = SYMBOL_TYPE (sym1); 4673 const char *name0 = SYMBOL_LINKAGE_NAME (sym0); 4674 const char *name1 = SYMBOL_LINKAGE_NAME (sym1); 4675 int len0 = strlen (name0); 4676 4677 return 4678 TYPE_CODE (type0) == TYPE_CODE (type1) 4679 && (equiv_types (type0, type1) 4680 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0 4681 && startswith (name1 + len0, "___XV"))); 4682 } 4683 case LOC_CONST: 4684 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1) 4685 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1)); 4686 default: 4687 return 0; 4688 } 4689} 4690 4691/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info 4692 records in OBSTACKP. Do nothing if SYM is a duplicate. */ 4693 4694static void 4695add_defn_to_vec (struct obstack *obstackp, 4696 struct symbol *sym, 4697 const struct block *block) 4698{ 4699 int i; 4700 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0); 4701 4702 /* Do not try to complete stub types, as the debugger is probably 4703 already scanning all symbols matching a certain name at the 4704 time when this function is called. Trying to replace the stub 4705 type by its associated full type will cause us to restart a scan 4706 which may lead to an infinite recursion. Instead, the client 4707 collecting the matching symbols will end up collecting several 4708 matches, with at least one of them complete. It can then filter 4709 out the stub ones if needed. */ 4710 4711 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1) 4712 { 4713 if (lesseq_defined_than (sym, prevDefns[i].sym)) 4714 return; 4715 else if (lesseq_defined_than (prevDefns[i].sym, sym)) 4716 { 4717 prevDefns[i].sym = sym; 4718 prevDefns[i].block = block; 4719 return; 4720 } 4721 } 4722 4723 { 4724 struct ada_symbol_info info; 4725 4726 info.sym = sym; 4727 info.block = block; 4728 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info)); 4729 } 4730} 4731 4732/* Number of ada_symbol_info structures currently collected in 4733 current vector in *OBSTACKP. */ 4734 4735static int 4736num_defns_collected (struct obstack *obstackp) 4737{ 4738 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info); 4739} 4740 4741/* Vector of ada_symbol_info structures currently collected in current 4742 vector in *OBSTACKP. If FINISH, close off the vector and return 4743 its final address. */ 4744 4745static struct ada_symbol_info * 4746defns_collected (struct obstack *obstackp, int finish) 4747{ 4748 if (finish) 4749 return obstack_finish (obstackp); 4750 else 4751 return (struct ada_symbol_info *) obstack_base (obstackp); 4752} 4753 4754/* Return a bound minimal symbol matching NAME according to Ada 4755 decoding rules. Returns an invalid symbol if there is no such 4756 minimal symbol. Names prefixed with "standard__" are handled 4757 specially: "standard__" is first stripped off, and only static and 4758 global symbols are searched. */ 4759 4760struct bound_minimal_symbol 4761ada_lookup_simple_minsym (const char *name) 4762{ 4763 struct bound_minimal_symbol result; 4764 struct objfile *objfile; 4765 struct minimal_symbol *msymbol; 4766 const int wild_match_p = should_use_wild_match (name); 4767 4768 memset (&result, 0, sizeof (result)); 4769 4770 /* Special case: If the user specifies a symbol name inside package 4771 Standard, do a non-wild matching of the symbol name without 4772 the "standard__" prefix. This was primarily introduced in order 4773 to allow the user to specifically access the standard exceptions 4774 using, for instance, Standard.Constraint_Error when Constraint_Error 4775 is ambiguous (due to the user defining its own Constraint_Error 4776 entity inside its program). */ 4777 if (startswith (name, "standard__")) 4778 name += sizeof ("standard__") - 1; 4779 4780 ALL_MSYMBOLS (objfile, msymbol) 4781 { 4782 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p) 4783 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline) 4784 { 4785 result.minsym = msymbol; 4786 result.objfile = objfile; 4787 break; 4788 } 4789 } 4790 4791 return result; 4792} 4793 4794/* For all subprograms that statically enclose the subprogram of the 4795 selected frame, add symbols matching identifier NAME in DOMAIN 4796 and their blocks to the list of data in OBSTACKP, as for 4797 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME 4798 with a wildcard prefix. */ 4799 4800static void 4801add_symbols_from_enclosing_procs (struct obstack *obstackp, 4802 const char *name, domain_enum domain, 4803 int wild_match_p) 4804{ 4805} 4806 4807/* True if TYPE is definitely an artificial type supplied to a symbol 4808 for which no debugging information was given in the symbol file. */ 4809 4810static int 4811is_nondebugging_type (struct type *type) 4812{ 4813 const char *name = ada_type_name (type); 4814 4815 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0); 4816} 4817 4818/* Return nonzero if TYPE1 and TYPE2 are two enumeration types 4819 that are deemed "identical" for practical purposes. 4820 4821 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM 4822 types and that their number of enumerals is identical (in other 4823 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */ 4824 4825static int 4826ada_identical_enum_types_p (struct type *type1, struct type *type2) 4827{ 4828 int i; 4829 4830 /* The heuristic we use here is fairly conservative. We consider 4831 that 2 enumerate types are identical if they have the same 4832 number of enumerals and that all enumerals have the same 4833 underlying value and name. */ 4834 4835 /* All enums in the type should have an identical underlying value. */ 4836 for (i = 0; i < TYPE_NFIELDS (type1); i++) 4837 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i)) 4838 return 0; 4839 4840 /* All enumerals should also have the same name (modulo any numerical 4841 suffix). */ 4842 for (i = 0; i < TYPE_NFIELDS (type1); i++) 4843 { 4844 const char *name_1 = TYPE_FIELD_NAME (type1, i); 4845 const char *name_2 = TYPE_FIELD_NAME (type2, i); 4846 int len_1 = strlen (name_1); 4847 int len_2 = strlen (name_2); 4848 4849 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1); 4850 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2); 4851 if (len_1 != len_2 4852 || strncmp (TYPE_FIELD_NAME (type1, i), 4853 TYPE_FIELD_NAME (type2, i), 4854 len_1) != 0) 4855 return 0; 4856 } 4857 4858 return 1; 4859} 4860 4861/* Return nonzero if all the symbols in SYMS are all enumeral symbols 4862 that are deemed "identical" for practical purposes. Sometimes, 4863 enumerals are not strictly identical, but their types are so similar 4864 that they can be considered identical. 4865 4866 For instance, consider the following code: 4867 4868 type Color is (Black, Red, Green, Blue, White); 4869 type RGB_Color is new Color range Red .. Blue; 4870 4871 Type RGB_Color is a subrange of an implicit type which is a copy 4872 of type Color. If we call that implicit type RGB_ColorB ("B" is 4873 for "Base Type"), then type RGB_ColorB is a copy of type Color. 4874 As a result, when an expression references any of the enumeral 4875 by name (Eg. "print green"), the expression is technically 4876 ambiguous and the user should be asked to disambiguate. But 4877 doing so would only hinder the user, since it wouldn't matter 4878 what choice he makes, the outcome would always be the same. 4879 So, for practical purposes, we consider them as the same. */ 4880 4881static int 4882symbols_are_identical_enums (struct ada_symbol_info *syms, int nsyms) 4883{ 4884 int i; 4885 4886 /* Before performing a thorough comparison check of each type, 4887 we perform a series of inexpensive checks. We expect that these 4888 checks will quickly fail in the vast majority of cases, and thus 4889 help prevent the unnecessary use of a more expensive comparison. 4890 Said comparison also expects us to make some of these checks 4891 (see ada_identical_enum_types_p). */ 4892 4893 /* Quick check: All symbols should have an enum type. */ 4894 for (i = 0; i < nsyms; i++) 4895 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM) 4896 return 0; 4897 4898 /* Quick check: They should all have the same value. */ 4899 for (i = 1; i < nsyms; i++) 4900 if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym)) 4901 return 0; 4902 4903 /* Quick check: They should all have the same number of enumerals. */ 4904 for (i = 1; i < nsyms; i++) 4905 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym)) 4906 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym))) 4907 return 0; 4908 4909 /* All the sanity checks passed, so we might have a set of 4910 identical enumeration types. Perform a more complete 4911 comparison of the type of each symbol. */ 4912 for (i = 1; i < nsyms; i++) 4913 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym), 4914 SYMBOL_TYPE (syms[0].sym))) 4915 return 0; 4916 4917 return 1; 4918} 4919 4920/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely 4921 duplicate other symbols in the list (The only case I know of where 4922 this happens is when object files containing stabs-in-ecoff are 4923 linked with files containing ordinary ecoff debugging symbols (or no 4924 debugging symbols)). Modifies SYMS to squeeze out deleted entries. 4925 Returns the number of items in the modified list. */ 4926 4927static int 4928remove_extra_symbols (struct ada_symbol_info *syms, int nsyms) 4929{ 4930 int i, j; 4931 4932 /* We should never be called with less than 2 symbols, as there 4933 cannot be any extra symbol in that case. But it's easy to 4934 handle, since we have nothing to do in that case. */ 4935 if (nsyms < 2) 4936 return nsyms; 4937 4938 i = 0; 4939 while (i < nsyms) 4940 { 4941 int remove_p = 0; 4942 4943 /* If two symbols have the same name and one of them is a stub type, 4944 the get rid of the stub. */ 4945 4946 if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym)) 4947 && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL) 4948 { 4949 for (j = 0; j < nsyms; j++) 4950 { 4951 if (j != i 4952 && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym)) 4953 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL 4954 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym), 4955 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0) 4956 remove_p = 1; 4957 } 4958 } 4959 4960 /* Two symbols with the same name, same class and same address 4961 should be identical. */ 4962 4963 else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL 4964 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC 4965 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym))) 4966 { 4967 for (j = 0; j < nsyms; j += 1) 4968 { 4969 if (i != j 4970 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL 4971 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym), 4972 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0 4973 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym) 4974 && SYMBOL_VALUE_ADDRESS (syms[i].sym) 4975 == SYMBOL_VALUE_ADDRESS (syms[j].sym)) 4976 remove_p = 1; 4977 } 4978 } 4979 4980 if (remove_p) 4981 { 4982 for (j = i + 1; j < nsyms; j += 1) 4983 syms[j - 1] = syms[j]; 4984 nsyms -= 1; 4985 } 4986 4987 i += 1; 4988 } 4989 4990 /* If all the remaining symbols are identical enumerals, then 4991 just keep the first one and discard the rest. 4992 4993 Unlike what we did previously, we do not discard any entry 4994 unless they are ALL identical. This is because the symbol 4995 comparison is not a strict comparison, but rather a practical 4996 comparison. If all symbols are considered identical, then 4997 we can just go ahead and use the first one and discard the rest. 4998 But if we cannot reduce the list to a single element, we have 4999 to ask the user to disambiguate anyways. And if we have to 5000 present a multiple-choice menu, it's less confusing if the list 5001 isn't missing some choices that were identical and yet distinct. */ 5002 if (symbols_are_identical_enums (syms, nsyms)) 5003 nsyms = 1; 5004 5005 return nsyms; 5006} 5007 5008/* Given a type that corresponds to a renaming entity, use the type name 5009 to extract the scope (package name or function name, fully qualified, 5010 and following the GNAT encoding convention) where this renaming has been 5011 defined. The string returned needs to be deallocated after use. */ 5012 5013static char * 5014xget_renaming_scope (struct type *renaming_type) 5015{ 5016 /* The renaming types adhere to the following convention: 5017 <scope>__<rename>___<XR extension>. 5018 So, to extract the scope, we search for the "___XR" extension, 5019 and then backtrack until we find the first "__". */ 5020 5021 const char *name = type_name_no_tag (renaming_type); 5022 char *suffix = strstr (name, "___XR"); 5023 char *last; 5024 int scope_len; 5025 char *scope; 5026 5027 /* Now, backtrack a bit until we find the first "__". Start looking 5028 at suffix - 3, as the <rename> part is at least one character long. */ 5029 5030 for (last = suffix - 3; last > name; last--) 5031 if (last[0] == '_' && last[1] == '_') 5032 break; 5033 5034 /* Make a copy of scope and return it. */ 5035 5036 scope_len = last - name; 5037 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char)); 5038 5039 strncpy (scope, name, scope_len); 5040 scope[scope_len] = '\0'; 5041 5042 return scope; 5043} 5044 5045/* Return nonzero if NAME corresponds to a package name. */ 5046 5047static int 5048is_package_name (const char *name) 5049{ 5050 /* Here, We take advantage of the fact that no symbols are generated 5051 for packages, while symbols are generated for each function. 5052 So the condition for NAME represent a package becomes equivalent 5053 to NAME not existing in our list of symbols. There is only one 5054 small complication with library-level functions (see below). */ 5055 5056 char *fun_name; 5057 5058 /* If it is a function that has not been defined at library level, 5059 then we should be able to look it up in the symbols. */ 5060 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL) 5061 return 0; 5062 5063 /* Library-level function names start with "_ada_". See if function 5064 "_ada_" followed by NAME can be found. */ 5065 5066 /* Do a quick check that NAME does not contain "__", since library-level 5067 functions names cannot contain "__" in them. */ 5068 if (strstr (name, "__") != NULL) 5069 return 0; 5070 5071 fun_name = xstrprintf ("_ada_%s", name); 5072 5073 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL); 5074} 5075 5076/* Return nonzero if SYM corresponds to a renaming entity that is 5077 not visible from FUNCTION_NAME. */ 5078 5079static int 5080old_renaming_is_invisible (const struct symbol *sym, const char *function_name) 5081{ 5082 char *scope; 5083 struct cleanup *old_chain; 5084 5085 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF) 5086 return 0; 5087 5088 scope = xget_renaming_scope (SYMBOL_TYPE (sym)); 5089 old_chain = make_cleanup (xfree, scope); 5090 5091 /* If the rename has been defined in a package, then it is visible. */ 5092 if (is_package_name (scope)) 5093 { 5094 do_cleanups (old_chain); 5095 return 0; 5096 } 5097 5098 /* Check that the rename is in the current function scope by checking 5099 that its name starts with SCOPE. */ 5100 5101 /* If the function name starts with "_ada_", it means that it is 5102 a library-level function. Strip this prefix before doing the 5103 comparison, as the encoding for the renaming does not contain 5104 this prefix. */ 5105 if (startswith (function_name, "_ada_")) 5106 function_name += 5; 5107 5108 { 5109 int is_invisible = !startswith (function_name, scope); 5110 5111 do_cleanups (old_chain); 5112 return is_invisible; 5113 } 5114} 5115 5116/* Remove entries from SYMS that corresponds to a renaming entity that 5117 is not visible from the function associated with CURRENT_BLOCK or 5118 that is superfluous due to the presence of more specific renaming 5119 information. Places surviving symbols in the initial entries of 5120 SYMS and returns the number of surviving symbols. 5121 5122 Rationale: 5123 First, in cases where an object renaming is implemented as a 5124 reference variable, GNAT may produce both the actual reference 5125 variable and the renaming encoding. In this case, we discard the 5126 latter. 5127 5128 Second, GNAT emits a type following a specified encoding for each renaming 5129 entity. Unfortunately, STABS currently does not support the definition 5130 of types that are local to a given lexical block, so all renamings types 5131 are emitted at library level. As a consequence, if an application 5132 contains two renaming entities using the same name, and a user tries to 5133 print the value of one of these entities, the result of the ada symbol 5134 lookup will also contain the wrong renaming type. 5135 5136 This function partially covers for this limitation by attempting to 5137 remove from the SYMS list renaming symbols that should be visible 5138 from CURRENT_BLOCK. However, there does not seem be a 100% reliable 5139 method with the current information available. The implementation 5140 below has a couple of limitations (FIXME: brobecker-2003-05-12): 5141 5142 - When the user tries to print a rename in a function while there 5143 is another rename entity defined in a package: Normally, the 5144 rename in the function has precedence over the rename in the 5145 package, so the latter should be removed from the list. This is 5146 currently not the case. 5147 5148 - This function will incorrectly remove valid renames if 5149 the CURRENT_BLOCK corresponds to a function which symbol name 5150 has been changed by an "Export" pragma. As a consequence, 5151 the user will be unable to print such rename entities. */ 5152 5153static int 5154remove_irrelevant_renamings (struct ada_symbol_info *syms, 5155 int nsyms, const struct block *current_block) 5156{ 5157 struct symbol *current_function; 5158 const char *current_function_name; 5159 int i; 5160 int is_new_style_renaming; 5161 5162 /* If there is both a renaming foo___XR... encoded as a variable and 5163 a simple variable foo in the same block, discard the latter. 5164 First, zero out such symbols, then compress. */ 5165 is_new_style_renaming = 0; 5166 for (i = 0; i < nsyms; i += 1) 5167 { 5168 struct symbol *sym = syms[i].sym; 5169 const struct block *block = syms[i].block; 5170 const char *name; 5171 const char *suffix; 5172 5173 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF) 5174 continue; 5175 name = SYMBOL_LINKAGE_NAME (sym); 5176 suffix = strstr (name, "___XR"); 5177 5178 if (suffix != NULL) 5179 { 5180 int name_len = suffix - name; 5181 int j; 5182 5183 is_new_style_renaming = 1; 5184 for (j = 0; j < nsyms; j += 1) 5185 if (i != j && syms[j].sym != NULL 5186 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym), 5187 name_len) == 0 5188 && block == syms[j].block) 5189 syms[j].sym = NULL; 5190 } 5191 } 5192 if (is_new_style_renaming) 5193 { 5194 int j, k; 5195 5196 for (j = k = 0; j < nsyms; j += 1) 5197 if (syms[j].sym != NULL) 5198 { 5199 syms[k] = syms[j]; 5200 k += 1; 5201 } 5202 return k; 5203 } 5204 5205 /* Extract the function name associated to CURRENT_BLOCK. 5206 Abort if unable to do so. */ 5207 5208 if (current_block == NULL) 5209 return nsyms; 5210 5211 current_function = block_linkage_function (current_block); 5212 if (current_function == NULL) 5213 return nsyms; 5214 5215 current_function_name = SYMBOL_LINKAGE_NAME (current_function); 5216 if (current_function_name == NULL) 5217 return nsyms; 5218 5219 /* Check each of the symbols, and remove it from the list if it is 5220 a type corresponding to a renaming that is out of the scope of 5221 the current block. */ 5222 5223 i = 0; 5224 while (i < nsyms) 5225 { 5226 if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL) 5227 == ADA_OBJECT_RENAMING 5228 && old_renaming_is_invisible (syms[i].sym, current_function_name)) 5229 { 5230 int j; 5231 5232 for (j = i + 1; j < nsyms; j += 1) 5233 syms[j - 1] = syms[j]; 5234 nsyms -= 1; 5235 } 5236 else 5237 i += 1; 5238 } 5239 5240 return nsyms; 5241} 5242 5243/* Add to OBSTACKP all symbols from BLOCK (and its super-blocks) 5244 whose name and domain match NAME and DOMAIN respectively. 5245 If no match was found, then extend the search to "enclosing" 5246 routines (in other words, if we're inside a nested function, 5247 search the symbols defined inside the enclosing functions). 5248 If WILD_MATCH_P is nonzero, perform the naming matching in 5249 "wild" mode (see function "wild_match" for more info). 5250 5251 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */ 5252 5253static void 5254ada_add_local_symbols (struct obstack *obstackp, const char *name, 5255 const struct block *block, domain_enum domain, 5256 int wild_match_p) 5257{ 5258 int block_depth = 0; 5259 5260 while (block != NULL) 5261 { 5262 block_depth += 1; 5263 ada_add_block_symbols (obstackp, block, name, domain, NULL, 5264 wild_match_p); 5265 5266 /* If we found a non-function match, assume that's the one. */ 5267 if (is_nonfunction (defns_collected (obstackp, 0), 5268 num_defns_collected (obstackp))) 5269 return; 5270 5271 block = BLOCK_SUPERBLOCK (block); 5272 } 5273 5274 /* If no luck so far, try to find NAME as a local symbol in some lexically 5275 enclosing subprogram. */ 5276 if (num_defns_collected (obstackp) == 0 && block_depth > 2) 5277 add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p); 5278} 5279 5280/* An object of this type is used as the user_data argument when 5281 calling the map_matching_symbols method. */ 5282 5283struct match_data 5284{ 5285 struct objfile *objfile; 5286 struct obstack *obstackp; 5287 struct symbol *arg_sym; 5288 int found_sym; 5289}; 5290 5291/* A callback for add_matching_symbols that adds SYM, found in BLOCK, 5292 to a list of symbols. DATA0 is a pointer to a struct match_data * 5293 containing the obstack that collects the symbol list, the file that SYM 5294 must come from, a flag indicating whether a non-argument symbol has 5295 been found in the current block, and the last argument symbol 5296 passed in SYM within the current block (if any). When SYM is null, 5297 marking the end of a block, the argument symbol is added if no 5298 other has been found. */ 5299 5300static int 5301aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0) 5302{ 5303 struct match_data *data = (struct match_data *) data0; 5304 5305 if (sym == NULL) 5306 { 5307 if (!data->found_sym && data->arg_sym != NULL) 5308 add_defn_to_vec (data->obstackp, 5309 fixup_symbol_section (data->arg_sym, data->objfile), 5310 block); 5311 data->found_sym = 0; 5312 data->arg_sym = NULL; 5313 } 5314 else 5315 { 5316 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED) 5317 return 0; 5318 else if (SYMBOL_IS_ARGUMENT (sym)) 5319 data->arg_sym = sym; 5320 else 5321 { 5322 data->found_sym = 1; 5323 add_defn_to_vec (data->obstackp, 5324 fixup_symbol_section (sym, data->objfile), 5325 block); 5326 } 5327 } 5328 return 0; 5329} 5330 5331/* Implements compare_names, but only applying the comparision using 5332 the given CASING. */ 5333 5334static int 5335compare_names_with_case (const char *string1, const char *string2, 5336 enum case_sensitivity casing) 5337{ 5338 while (*string1 != '\0' && *string2 != '\0') 5339 { 5340 char c1, c2; 5341 5342 if (isspace (*string1) || isspace (*string2)) 5343 return strcmp_iw_ordered (string1, string2); 5344 5345 if (casing == case_sensitive_off) 5346 { 5347 c1 = tolower (*string1); 5348 c2 = tolower (*string2); 5349 } 5350 else 5351 { 5352 c1 = *string1; 5353 c2 = *string2; 5354 } 5355 if (c1 != c2) 5356 break; 5357 5358 string1 += 1; 5359 string2 += 1; 5360 } 5361 5362 switch (*string1) 5363 { 5364 case '(': 5365 return strcmp_iw_ordered (string1, string2); 5366 case '_': 5367 if (*string2 == '\0') 5368 { 5369 if (is_name_suffix (string1)) 5370 return 0; 5371 else 5372 return 1; 5373 } 5374 /* FALLTHROUGH */ 5375 default: 5376 if (*string2 == '(') 5377 return strcmp_iw_ordered (string1, string2); 5378 else 5379 { 5380 if (casing == case_sensitive_off) 5381 return tolower (*string1) - tolower (*string2); 5382 else 5383 return *string1 - *string2; 5384 } 5385 } 5386} 5387 5388/* Compare STRING1 to STRING2, with results as for strcmp. 5389 Compatible with strcmp_iw_ordered in that... 5390 5391 strcmp_iw_ordered (STRING1, STRING2) <= 0 5392 5393 ... implies... 5394 5395 compare_names (STRING1, STRING2) <= 0 5396 5397 (they may differ as to what symbols compare equal). */ 5398 5399static int 5400compare_names (const char *string1, const char *string2) 5401{ 5402 int result; 5403 5404 /* Similar to what strcmp_iw_ordered does, we need to perform 5405 a case-insensitive comparison first, and only resort to 5406 a second, case-sensitive, comparison if the first one was 5407 not sufficient to differentiate the two strings. */ 5408 5409 result = compare_names_with_case (string1, string2, case_sensitive_off); 5410 if (result == 0) 5411 result = compare_names_with_case (string1, string2, case_sensitive_on); 5412 5413 return result; 5414} 5415 5416/* Add to OBSTACKP all non-local symbols whose name and domain match 5417 NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK 5418 symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */ 5419 5420static void 5421add_nonlocal_symbols (struct obstack *obstackp, const char *name, 5422 domain_enum domain, int global, 5423 int is_wild_match) 5424{ 5425 struct objfile *objfile; 5426 struct match_data data; 5427 5428 memset (&data, 0, sizeof data); 5429 data.obstackp = obstackp; 5430 5431 ALL_OBJFILES (objfile) 5432 { 5433 data.objfile = objfile; 5434 5435 if (is_wild_match) 5436 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global, 5437 aux_add_nonlocal_symbols, &data, 5438 wild_match, NULL); 5439 else 5440 objfile->sf->qf->map_matching_symbols (objfile, name, domain, global, 5441 aux_add_nonlocal_symbols, &data, 5442 full_match, compare_names); 5443 } 5444 5445 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match) 5446 { 5447 ALL_OBJFILES (objfile) 5448 { 5449 char *name1 = alloca (strlen (name) + sizeof ("_ada_")); 5450 strcpy (name1, "_ada_"); 5451 strcpy (name1 + sizeof ("_ada_") - 1, name); 5452 data.objfile = objfile; 5453 objfile->sf->qf->map_matching_symbols (objfile, name1, domain, 5454 global, 5455 aux_add_nonlocal_symbols, 5456 &data, 5457 full_match, compare_names); 5458 } 5459 } 5460} 5461 5462/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is 5463 non-zero, enclosing scope and in global scopes, returning the number of 5464 matches. 5465 Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples, 5466 indicating the symbols found and the blocks and symbol tables (if 5467 any) in which they were found. This vector is transient---good only to 5468 the next call of ada_lookup_symbol_list. 5469 5470 When full_search is non-zero, any non-function/non-enumeral 5471 symbol match within the nest of blocks whose innermost member is BLOCK0, 5472 is the one match returned (no other matches in that or 5473 enclosing blocks is returned). If there are any matches in or 5474 surrounding BLOCK0, then these alone are returned. 5475 5476 Names prefixed with "standard__" are handled specially: "standard__" 5477 is first stripped off, and only static and global symbols are searched. */ 5478 5479static int 5480ada_lookup_symbol_list_worker (const char *name0, const struct block *block0, 5481 domain_enum domain, 5482 struct ada_symbol_info **results, 5483 int full_search) 5484{ 5485 struct symbol *sym; 5486 const struct block *block; 5487 const char *name; 5488 const int wild_match_p = should_use_wild_match (name0); 5489 int syms_from_global_search = 0; 5490 int ndefns; 5491 5492 obstack_free (&symbol_list_obstack, NULL); 5493 obstack_init (&symbol_list_obstack); 5494 5495 /* Search specified block and its superiors. */ 5496 5497 name = name0; 5498 block = block0; 5499 5500 /* Special case: If the user specifies a symbol name inside package 5501 Standard, do a non-wild matching of the symbol name without 5502 the "standard__" prefix. This was primarily introduced in order 5503 to allow the user to specifically access the standard exceptions 5504 using, for instance, Standard.Constraint_Error when Constraint_Error 5505 is ambiguous (due to the user defining its own Constraint_Error 5506 entity inside its program). */ 5507 if (startswith (name0, "standard__")) 5508 { 5509 block = NULL; 5510 name = name0 + sizeof ("standard__") - 1; 5511 } 5512 5513 /* Check the non-global symbols. If we have ANY match, then we're done. */ 5514 5515 if (block != NULL) 5516 { 5517 if (full_search) 5518 { 5519 ada_add_local_symbols (&symbol_list_obstack, name, block, 5520 domain, wild_match_p); 5521 } 5522 else 5523 { 5524 /* In the !full_search case we're are being called by 5525 ada_iterate_over_symbols, and we don't want to search 5526 superblocks. */ 5527 ada_add_block_symbols (&symbol_list_obstack, block, name, 5528 domain, NULL, wild_match_p); 5529 } 5530 if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search) 5531 goto done; 5532 } 5533 5534 /* No non-global symbols found. Check our cache to see if we have 5535 already performed this search before. If we have, then return 5536 the same result. */ 5537 5538 if (lookup_cached_symbol (name0, domain, &sym, &block)) 5539 { 5540 if (sym != NULL) 5541 add_defn_to_vec (&symbol_list_obstack, sym, block); 5542 goto done; 5543 } 5544 5545 syms_from_global_search = 1; 5546 5547 /* Search symbols from all global blocks. */ 5548 5549 add_nonlocal_symbols (&symbol_list_obstack, name, domain, 1, 5550 wild_match_p); 5551 5552 /* Now add symbols from all per-file blocks if we've gotten no hits 5553 (not strictly correct, but perhaps better than an error). */ 5554 5555 if (num_defns_collected (&symbol_list_obstack) == 0) 5556 add_nonlocal_symbols (&symbol_list_obstack, name, domain, 0, 5557 wild_match_p); 5558 5559done: 5560 ndefns = num_defns_collected (&symbol_list_obstack); 5561 *results = defns_collected (&symbol_list_obstack, 1); 5562 5563 ndefns = remove_extra_symbols (*results, ndefns); 5564 5565 if (ndefns == 0 && full_search && syms_from_global_search) 5566 cache_symbol (name0, domain, NULL, NULL); 5567 5568 if (ndefns == 1 && full_search && syms_from_global_search) 5569 cache_symbol (name0, domain, (*results)[0].sym, (*results)[0].block); 5570 5571 ndefns = remove_irrelevant_renamings (*results, ndefns, block0); 5572 5573 return ndefns; 5574} 5575 5576/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and 5577 in global scopes, returning the number of matches, and setting *RESULTS 5578 to a vector of (SYM,BLOCK) tuples. 5579 See ada_lookup_symbol_list_worker for further details. */ 5580 5581int 5582ada_lookup_symbol_list (const char *name0, const struct block *block0, 5583 domain_enum domain, struct ada_symbol_info **results) 5584{ 5585 return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1); 5586} 5587 5588/* Implementation of the la_iterate_over_symbols method. */ 5589 5590static void 5591ada_iterate_over_symbols (const struct block *block, 5592 const char *name, domain_enum domain, 5593 symbol_found_callback_ftype *callback, 5594 void *data) 5595{ 5596 int ndefs, i; 5597 struct ada_symbol_info *results; 5598 5599 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0); 5600 for (i = 0; i < ndefs; ++i) 5601 { 5602 if (! (*callback) (results[i].sym, data)) 5603 break; 5604 } 5605} 5606 5607/* If NAME is the name of an entity, return a string that should 5608 be used to look that entity up in Ada units. This string should 5609 be deallocated after use using xfree. 5610 5611 NAME can have any form that the "break" or "print" commands might 5612 recognize. In other words, it does not have to be the "natural" 5613 name, or the "encoded" name. */ 5614 5615char * 5616ada_name_for_lookup (const char *name) 5617{ 5618 char *canon; 5619 int nlen = strlen (name); 5620 5621 if (name[0] == '<' && name[nlen - 1] == '>') 5622 { 5623 canon = xmalloc (nlen - 1); 5624 memcpy (canon, name + 1, nlen - 2); 5625 canon[nlen - 2] = '\0'; 5626 } 5627 else 5628 canon = xstrdup (ada_encode (ada_fold_name (name))); 5629 return canon; 5630} 5631 5632/* The result is as for ada_lookup_symbol_list with FULL_SEARCH set 5633 to 1, but choosing the first symbol found if there are multiple 5634 choices. 5635 5636 The result is stored in *INFO, which must be non-NULL. 5637 If no match is found, INFO->SYM is set to NULL. */ 5638 5639void 5640ada_lookup_encoded_symbol (const char *name, const struct block *block, 5641 domain_enum domain, 5642 struct ada_symbol_info *info) 5643{ 5644 struct ada_symbol_info *candidates; 5645 int n_candidates; 5646 5647 gdb_assert (info != NULL); 5648 memset (info, 0, sizeof (struct ada_symbol_info)); 5649 5650 n_candidates = ada_lookup_symbol_list (name, block, domain, &candidates); 5651 if (n_candidates == 0) 5652 return; 5653 5654 *info = candidates[0]; 5655 info->sym = fixup_symbol_section (info->sym, NULL); 5656} 5657 5658/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing 5659 scope and in global scopes, or NULL if none. NAME is folded and 5660 encoded first. Otherwise, the result is as for ada_lookup_symbol_list, 5661 choosing the first symbol if there are multiple choices. 5662 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */ 5663 5664struct symbol * 5665ada_lookup_symbol (const char *name, const struct block *block0, 5666 domain_enum domain, int *is_a_field_of_this) 5667{ 5668 struct ada_symbol_info info; 5669 5670 if (is_a_field_of_this != NULL) 5671 *is_a_field_of_this = 0; 5672 5673 ada_lookup_encoded_symbol (ada_encode (ada_fold_name (name)), 5674 block0, domain, &info); 5675 return info.sym; 5676} 5677 5678static struct symbol * 5679ada_lookup_symbol_nonlocal (const struct language_defn *langdef, 5680 const char *name, 5681 const struct block *block, 5682 const domain_enum domain) 5683{ 5684 struct symbol *sym; 5685 5686 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL); 5687 if (sym != NULL) 5688 return sym; 5689 5690 /* If we haven't found a match at this point, try the primitive 5691 types. In other languages, this search is performed before 5692 searching for global symbols in order to short-circuit that 5693 global-symbol search if it happens that the name corresponds 5694 to a primitive type. But we cannot do the same in Ada, because 5695 it is perfectly legitimate for a program to declare a type which 5696 has the same name as a standard type. If looking up a type in 5697 that situation, we have traditionally ignored the primitive type 5698 in favor of user-defined types. This is why, unlike most other 5699 languages, we search the primitive types this late and only after 5700 having searched the global symbols without success. */ 5701 5702 if (domain == VAR_DOMAIN) 5703 { 5704 struct gdbarch *gdbarch; 5705 5706 if (block == NULL) 5707 gdbarch = target_gdbarch (); 5708 else 5709 gdbarch = block_gdbarch (block); 5710 sym = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name); 5711 if (sym != NULL) 5712 return sym; 5713 } 5714 5715 return NULL; 5716} 5717 5718 5719/* True iff STR is a possible encoded suffix of a normal Ada name 5720 that is to be ignored for matching purposes. Suffixes of parallel 5721 names (e.g., XVE) are not included here. Currently, the possible suffixes 5722 are given by any of the regular expressions: 5723 5724 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux] 5725 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX] 5726 TKB [subprogram suffix for task bodies] 5727 _E[0-9]+[bs]$ [protected object entry suffixes] 5728 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$ 5729 5730 Also, any leading "__[0-9]+" sequence is skipped before the suffix 5731 match is performed. This sequence is used to differentiate homonyms, 5732 is an optional part of a valid name suffix. */ 5733 5734static int 5735is_name_suffix (const char *str) 5736{ 5737 int k; 5738 const char *matching; 5739 const int len = strlen (str); 5740 5741 /* Skip optional leading __[0-9]+. */ 5742 5743 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2])) 5744 { 5745 str += 3; 5746 while (isdigit (str[0])) 5747 str += 1; 5748 } 5749 5750 /* [.$][0-9]+ */ 5751 5752 if (str[0] == '.' || str[0] == '$') 5753 { 5754 matching = str + 1; 5755 while (isdigit (matching[0])) 5756 matching += 1; 5757 if (matching[0] == '\0') 5758 return 1; 5759 } 5760 5761 /* ___[0-9]+ */ 5762 5763 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_') 5764 { 5765 matching = str + 3; 5766 while (isdigit (matching[0])) 5767 matching += 1; 5768 if (matching[0] == '\0') 5769 return 1; 5770 } 5771 5772 /* "TKB" suffixes are used for subprograms implementing task bodies. */ 5773 5774 if (strcmp (str, "TKB") == 0) 5775 return 1; 5776 5777#if 0 5778 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end 5779 with a N at the end. Unfortunately, the compiler uses the same 5780 convention for other internal types it creates. So treating 5781 all entity names that end with an "N" as a name suffix causes 5782 some regressions. For instance, consider the case of an enumerated 5783 type. To support the 'Image attribute, it creates an array whose 5784 name ends with N. 5785 Having a single character like this as a suffix carrying some 5786 information is a bit risky. Perhaps we should change the encoding 5787 to be something like "_N" instead. In the meantime, do not do 5788 the following check. */ 5789 /* Protected Object Subprograms */ 5790 if (len == 1 && str [0] == 'N') 5791 return 1; 5792#endif 5793 5794 /* _E[0-9]+[bs]$ */ 5795 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2])) 5796 { 5797 matching = str + 3; 5798 while (isdigit (matching[0])) 5799 matching += 1; 5800 if ((matching[0] == 'b' || matching[0] == 's') 5801 && matching [1] == '\0') 5802 return 1; 5803 } 5804 5805 /* ??? We should not modify STR directly, as we are doing below. This 5806 is fine in this case, but may become problematic later if we find 5807 that this alternative did not work, and want to try matching 5808 another one from the begining of STR. Since we modified it, we 5809 won't be able to find the begining of the string anymore! */ 5810 if (str[0] == 'X') 5811 { 5812 str += 1; 5813 while (str[0] != '_' && str[0] != '\0') 5814 { 5815 if (str[0] != 'n' && str[0] != 'b') 5816 return 0; 5817 str += 1; 5818 } 5819 } 5820 5821 if (str[0] == '\000') 5822 return 1; 5823 5824 if (str[0] == '_') 5825 { 5826 if (str[1] != '_' || str[2] == '\000') 5827 return 0; 5828 if (str[2] == '_') 5829 { 5830 if (strcmp (str + 3, "JM") == 0) 5831 return 1; 5832 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using 5833 the LJM suffix in favor of the JM one. But we will 5834 still accept LJM as a valid suffix for a reasonable 5835 amount of time, just to allow ourselves to debug programs 5836 compiled using an older version of GNAT. */ 5837 if (strcmp (str + 3, "LJM") == 0) 5838 return 1; 5839 if (str[3] != 'X') 5840 return 0; 5841 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B' 5842 || str[4] == 'U' || str[4] == 'P') 5843 return 1; 5844 if (str[4] == 'R' && str[5] != 'T') 5845 return 1; 5846 return 0; 5847 } 5848 if (!isdigit (str[2])) 5849 return 0; 5850 for (k = 3; str[k] != '\0'; k += 1) 5851 if (!isdigit (str[k]) && str[k] != '_') 5852 return 0; 5853 return 1; 5854 } 5855 if (str[0] == '$' && isdigit (str[1])) 5856 { 5857 for (k = 2; str[k] != '\0'; k += 1) 5858 if (!isdigit (str[k]) && str[k] != '_') 5859 return 0; 5860 return 1; 5861 } 5862 return 0; 5863} 5864 5865/* Return non-zero if the string starting at NAME and ending before 5866 NAME_END contains no capital letters. */ 5867 5868static int 5869is_valid_name_for_wild_match (const char *name0) 5870{ 5871 const char *decoded_name = ada_decode (name0); 5872 int i; 5873 5874 /* If the decoded name starts with an angle bracket, it means that 5875 NAME0 does not follow the GNAT encoding format. It should then 5876 not be allowed as a possible wild match. */ 5877 if (decoded_name[0] == '<') 5878 return 0; 5879 5880 for (i=0; decoded_name[i] != '\0'; i++) 5881 if (isalpha (decoded_name[i]) && !islower (decoded_name[i])) 5882 return 0; 5883 5884 return 1; 5885} 5886 5887/* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0 5888 that could start a simple name. Assumes that *NAMEP points into 5889 the string beginning at NAME0. */ 5890 5891static int 5892advance_wild_match (const char **namep, const char *name0, int target0) 5893{ 5894 const char *name = *namep; 5895 5896 while (1) 5897 { 5898 int t0, t1; 5899 5900 t0 = *name; 5901 if (t0 == '_') 5902 { 5903 t1 = name[1]; 5904 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9')) 5905 { 5906 name += 1; 5907 if (name == name0 + 5 && startswith (name0, "_ada")) 5908 break; 5909 else 5910 name += 1; 5911 } 5912 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z') 5913 || name[2] == target0)) 5914 { 5915 name += 2; 5916 break; 5917 } 5918 else 5919 return 0; 5920 } 5921 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9')) 5922 name += 1; 5923 else 5924 return 0; 5925 } 5926 5927 *namep = name; 5928 return 1; 5929} 5930 5931/* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any 5932 informational suffixes of NAME (i.e., for which is_name_suffix is 5933 true). Assumes that PATN is a lower-cased Ada simple name. */ 5934 5935static int 5936wild_match (const char *name, const char *patn) 5937{ 5938 const char *p; 5939 const char *name0 = name; 5940 5941 while (1) 5942 { 5943 const char *match = name; 5944 5945 if (*name == *patn) 5946 { 5947 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1) 5948 if (*p != *name) 5949 break; 5950 if (*p == '\0' && is_name_suffix (name)) 5951 return match != name0 && !is_valid_name_for_wild_match (name0); 5952 5953 if (name[-1] == '_') 5954 name -= 1; 5955 } 5956 if (!advance_wild_match (&name, name0, *patn)) 5957 return 1; 5958 } 5959} 5960 5961/* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from 5962 informational suffix. */ 5963 5964static int 5965full_match (const char *sym_name, const char *search_name) 5966{ 5967 return !match_name (sym_name, search_name, 0); 5968} 5969 5970 5971/* Add symbols from BLOCK matching identifier NAME in DOMAIN to 5972 vector *defn_symbols, updating the list of symbols in OBSTACKP 5973 (if necessary). If WILD, treat as NAME with a wildcard prefix. 5974 OBJFILE is the section containing BLOCK. */ 5975 5976static void 5977ada_add_block_symbols (struct obstack *obstackp, 5978 const struct block *block, const char *name, 5979 domain_enum domain, struct objfile *objfile, 5980 int wild) 5981{ 5982 struct block_iterator iter; 5983 int name_len = strlen (name); 5984 /* A matching argument symbol, if any. */ 5985 struct symbol *arg_sym; 5986 /* Set true when we find a matching non-argument symbol. */ 5987 int found_sym; 5988 struct symbol *sym; 5989 5990 arg_sym = NULL; 5991 found_sym = 0; 5992 if (wild) 5993 { 5994 for (sym = block_iter_match_first (block, name, wild_match, &iter); 5995 sym != NULL; sym = block_iter_match_next (name, wild_match, &iter)) 5996 { 5997 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym), 5998 SYMBOL_DOMAIN (sym), domain) 5999 && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0) 6000 { 6001 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED) 6002 continue; 6003 else if (SYMBOL_IS_ARGUMENT (sym)) 6004 arg_sym = sym; 6005 else 6006 { 6007 found_sym = 1; 6008 add_defn_to_vec (obstackp, 6009 fixup_symbol_section (sym, objfile), 6010 block); 6011 } 6012 } 6013 } 6014 } 6015 else 6016 { 6017 for (sym = block_iter_match_first (block, name, full_match, &iter); 6018 sym != NULL; sym = block_iter_match_next (name, full_match, &iter)) 6019 { 6020 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym), 6021 SYMBOL_DOMAIN (sym), domain)) 6022 { 6023 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED) 6024 { 6025 if (SYMBOL_IS_ARGUMENT (sym)) 6026 arg_sym = sym; 6027 else 6028 { 6029 found_sym = 1; 6030 add_defn_to_vec (obstackp, 6031 fixup_symbol_section (sym, objfile), 6032 block); 6033 } 6034 } 6035 } 6036 } 6037 } 6038 6039 if (!found_sym && arg_sym != NULL) 6040 { 6041 add_defn_to_vec (obstackp, 6042 fixup_symbol_section (arg_sym, objfile), 6043 block); 6044 } 6045 6046 if (!wild) 6047 { 6048 arg_sym = NULL; 6049 found_sym = 0; 6050 6051 ALL_BLOCK_SYMBOLS (block, iter, sym) 6052 { 6053 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym), 6054 SYMBOL_DOMAIN (sym), domain)) 6055 { 6056 int cmp; 6057 6058 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0]; 6059 if (cmp == 0) 6060 { 6061 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_"); 6062 if (cmp == 0) 6063 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5, 6064 name_len); 6065 } 6066 6067 if (cmp == 0 6068 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5)) 6069 { 6070 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED) 6071 { 6072 if (SYMBOL_IS_ARGUMENT (sym)) 6073 arg_sym = sym; 6074 else 6075 { 6076 found_sym = 1; 6077 add_defn_to_vec (obstackp, 6078 fixup_symbol_section (sym, objfile), 6079 block); 6080 } 6081 } 6082 } 6083 } 6084 } 6085 6086 /* NOTE: This really shouldn't be needed for _ada_ symbols. 6087 They aren't parameters, right? */ 6088 if (!found_sym && arg_sym != NULL) 6089 { 6090 add_defn_to_vec (obstackp, 6091 fixup_symbol_section (arg_sym, objfile), 6092 block); 6093 } 6094 } 6095} 6096 6097 6098 /* Symbol Completion */ 6099 6100/* If SYM_NAME is a completion candidate for TEXT, return this symbol 6101 name in a form that's appropriate for the completion. The result 6102 does not need to be deallocated, but is only good until the next call. 6103 6104 TEXT_LEN is equal to the length of TEXT. 6105 Perform a wild match if WILD_MATCH_P is set. 6106 ENCODED_P should be set if TEXT represents the start of a symbol name 6107 in its encoded form. */ 6108 6109static const char * 6110symbol_completion_match (const char *sym_name, 6111 const char *text, int text_len, 6112 int wild_match_p, int encoded_p) 6113{ 6114 const int verbatim_match = (text[0] == '<'); 6115 int match = 0; 6116 6117 if (verbatim_match) 6118 { 6119 /* Strip the leading angle bracket. */ 6120 text = text + 1; 6121 text_len--; 6122 } 6123 6124 /* First, test against the fully qualified name of the symbol. */ 6125 6126 if (strncmp (sym_name, text, text_len) == 0) 6127 match = 1; 6128 6129 if (match && !encoded_p) 6130 { 6131 /* One needed check before declaring a positive match is to verify 6132 that iff we are doing a verbatim match, the decoded version 6133 of the symbol name starts with '<'. Otherwise, this symbol name 6134 is not a suitable completion. */ 6135 const char *sym_name_copy = sym_name; 6136 int has_angle_bracket; 6137 6138 sym_name = ada_decode (sym_name); 6139 has_angle_bracket = (sym_name[0] == '<'); 6140 match = (has_angle_bracket == verbatim_match); 6141 sym_name = sym_name_copy; 6142 } 6143 6144 if (match && !verbatim_match) 6145 { 6146 /* When doing non-verbatim match, another check that needs to 6147 be done is to verify that the potentially matching symbol name 6148 does not include capital letters, because the ada-mode would 6149 not be able to understand these symbol names without the 6150 angle bracket notation. */ 6151 const char *tmp; 6152 6153 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++); 6154 if (*tmp != '\0') 6155 match = 0; 6156 } 6157 6158 /* Second: Try wild matching... */ 6159 6160 if (!match && wild_match_p) 6161 { 6162 /* Since we are doing wild matching, this means that TEXT 6163 may represent an unqualified symbol name. We therefore must 6164 also compare TEXT against the unqualified name of the symbol. */ 6165 sym_name = ada_unqualified_name (ada_decode (sym_name)); 6166 6167 if (strncmp (sym_name, text, text_len) == 0) 6168 match = 1; 6169 } 6170 6171 /* Finally: If we found a mach, prepare the result to return. */ 6172 6173 if (!match) 6174 return NULL; 6175 6176 if (verbatim_match) 6177 sym_name = add_angle_brackets (sym_name); 6178 6179 if (!encoded_p) 6180 sym_name = ada_decode (sym_name); 6181 6182 return sym_name; 6183} 6184 6185/* A companion function to ada_make_symbol_completion_list(). 6186 Check if SYM_NAME represents a symbol which name would be suitable 6187 to complete TEXT (TEXT_LEN is the length of TEXT), in which case 6188 it is appended at the end of the given string vector SV. 6189 6190 ORIG_TEXT is the string original string from the user command 6191 that needs to be completed. WORD is the entire command on which 6192 completion should be performed. These two parameters are used to 6193 determine which part of the symbol name should be added to the 6194 completion vector. 6195 if WILD_MATCH_P is set, then wild matching is performed. 6196 ENCODED_P should be set if TEXT represents a symbol name in its 6197 encoded formed (in which case the completion should also be 6198 encoded). */ 6199 6200static void 6201symbol_completion_add (VEC(char_ptr) **sv, 6202 const char *sym_name, 6203 const char *text, int text_len, 6204 const char *orig_text, const char *word, 6205 int wild_match_p, int encoded_p) 6206{ 6207 const char *match = symbol_completion_match (sym_name, text, text_len, 6208 wild_match_p, encoded_p); 6209 char *completion; 6210 6211 if (match == NULL) 6212 return; 6213 6214 /* We found a match, so add the appropriate completion to the given 6215 string vector. */ 6216 6217 if (word == orig_text) 6218 { 6219 completion = xmalloc (strlen (match) + 5); 6220 strcpy (completion, match); 6221 } 6222 else if (word > orig_text) 6223 { 6224 /* Return some portion of sym_name. */ 6225 completion = xmalloc (strlen (match) + 5); 6226 strcpy (completion, match + (word - orig_text)); 6227 } 6228 else 6229 { 6230 /* Return some of ORIG_TEXT plus sym_name. */ 6231 completion = xmalloc (strlen (match) + (orig_text - word) + 5); 6232 strncpy (completion, word, orig_text - word); 6233 completion[orig_text - word] = '\0'; 6234 strcat (completion, match); 6235 } 6236 6237 VEC_safe_push (char_ptr, *sv, completion); 6238} 6239 6240/* An object of this type is passed as the user_data argument to the 6241 expand_symtabs_matching method. */ 6242struct add_partial_datum 6243{ 6244 VEC(char_ptr) **completions; 6245 const char *text; 6246 int text_len; 6247 const char *text0; 6248 const char *word; 6249 int wild_match; 6250 int encoded; 6251}; 6252 6253/* A callback for expand_symtabs_matching. */ 6254 6255static int 6256ada_complete_symbol_matcher (const char *name, void *user_data) 6257{ 6258 struct add_partial_datum *data = user_data; 6259 6260 return symbol_completion_match (name, data->text, data->text_len, 6261 data->wild_match, data->encoded) != NULL; 6262} 6263 6264/* Return a list of possible symbol names completing TEXT0. WORD is 6265 the entire command on which completion is made. */ 6266 6267static VEC (char_ptr) * 6268ada_make_symbol_completion_list (const char *text0, const char *word, 6269 enum type_code code) 6270{ 6271 char *text; 6272 int text_len; 6273 int wild_match_p; 6274 int encoded_p; 6275 VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128); 6276 struct symbol *sym; 6277 struct compunit_symtab *s; 6278 struct minimal_symbol *msymbol; 6279 struct objfile *objfile; 6280 const struct block *b, *surrounding_static_block = 0; 6281 int i; 6282 struct block_iterator iter; 6283 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL); 6284 6285 gdb_assert (code == TYPE_CODE_UNDEF); 6286 6287 if (text0[0] == '<') 6288 { 6289 text = xstrdup (text0); 6290 make_cleanup (xfree, text); 6291 text_len = strlen (text); 6292 wild_match_p = 0; 6293 encoded_p = 1; 6294 } 6295 else 6296 { 6297 text = xstrdup (ada_encode (text0)); 6298 make_cleanup (xfree, text); 6299 text_len = strlen (text); 6300 for (i = 0; i < text_len; i++) 6301 text[i] = tolower (text[i]); 6302 6303 encoded_p = (strstr (text0, "__") != NULL); 6304 /* If the name contains a ".", then the user is entering a fully 6305 qualified entity name, and the match must not be done in wild 6306 mode. Similarly, if the user wants to complete what looks like 6307 an encoded name, the match must not be done in wild mode. */ 6308 wild_match_p = (strchr (text0, '.') == NULL && !encoded_p); 6309 } 6310 6311 /* First, look at the partial symtab symbols. */ 6312 { 6313 struct add_partial_datum data; 6314 6315 data.completions = &completions; 6316 data.text = text; 6317 data.text_len = text_len; 6318 data.text0 = text0; 6319 data.word = word; 6320 data.wild_match = wild_match_p; 6321 data.encoded = encoded_p; 6322 expand_symtabs_matching (NULL, ada_complete_symbol_matcher, NULL, 6323 ALL_DOMAIN, &data); 6324 } 6325 6326 /* At this point scan through the misc symbol vectors and add each 6327 symbol you find to the list. Eventually we want to ignore 6328 anything that isn't a text symbol (everything else will be 6329 handled by the psymtab code above). */ 6330 6331 ALL_MSYMBOLS (objfile, msymbol) 6332 { 6333 QUIT; 6334 symbol_completion_add (&completions, MSYMBOL_LINKAGE_NAME (msymbol), 6335 text, text_len, text0, word, wild_match_p, 6336 encoded_p); 6337 } 6338 6339 /* Search upwards from currently selected frame (so that we can 6340 complete on local vars. */ 6341 6342 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b)) 6343 { 6344 if (!BLOCK_SUPERBLOCK (b)) 6345 surrounding_static_block = b; /* For elmin of dups */ 6346 6347 ALL_BLOCK_SYMBOLS (b, iter, sym) 6348 { 6349 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym), 6350 text, text_len, text0, word, 6351 wild_match_p, encoded_p); 6352 } 6353 } 6354 6355 /* Go through the symtabs and check the externs and statics for 6356 symbols which match. */ 6357 6358 ALL_COMPUNITS (objfile, s) 6359 { 6360 QUIT; 6361 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK); 6362 ALL_BLOCK_SYMBOLS (b, iter, sym) 6363 { 6364 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym), 6365 text, text_len, text0, word, 6366 wild_match_p, encoded_p); 6367 } 6368 } 6369 6370 ALL_COMPUNITS (objfile, s) 6371 { 6372 QUIT; 6373 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK); 6374 /* Don't do this block twice. */ 6375 if (b == surrounding_static_block) 6376 continue; 6377 ALL_BLOCK_SYMBOLS (b, iter, sym) 6378 { 6379 symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym), 6380 text, text_len, text0, word, 6381 wild_match_p, encoded_p); 6382 } 6383 } 6384 6385 do_cleanups (old_chain); 6386 return completions; 6387} 6388 6389 /* Field Access */ 6390 6391/* Return non-zero if TYPE is a pointer to the GNAT dispatch table used 6392 for tagged types. */ 6393 6394static int 6395ada_is_dispatch_table_ptr_type (struct type *type) 6396{ 6397 const char *name; 6398 6399 if (TYPE_CODE (type) != TYPE_CODE_PTR) 6400 return 0; 6401 6402 name = TYPE_NAME (TYPE_TARGET_TYPE (type)); 6403 if (name == NULL) 6404 return 0; 6405 6406 return (strcmp (name, "ada__tags__dispatch_table") == 0); 6407} 6408 6409/* Return non-zero if TYPE is an interface tag. */ 6410 6411static int 6412ada_is_interface_tag (struct type *type) 6413{ 6414 const char *name = TYPE_NAME (type); 6415 6416 if (name == NULL) 6417 return 0; 6418 6419 return (strcmp (name, "ada__tags__interface_tag") == 0); 6420} 6421 6422/* True if field number FIELD_NUM in struct or union type TYPE is supposed 6423 to be invisible to users. */ 6424 6425int 6426ada_is_ignored_field (struct type *type, int field_num) 6427{ 6428 if (field_num < 0 || field_num > TYPE_NFIELDS (type)) 6429 return 1; 6430 6431 /* Check the name of that field. */ 6432 { 6433 const char *name = TYPE_FIELD_NAME (type, field_num); 6434 6435 /* Anonymous field names should not be printed. 6436 brobecker/2007-02-20: I don't think this can actually happen 6437 but we don't want to print the value of annonymous fields anyway. */ 6438 if (name == NULL) 6439 return 1; 6440 6441 /* Normally, fields whose name start with an underscore ("_") 6442 are fields that have been internally generated by the compiler, 6443 and thus should not be printed. The "_parent" field is special, 6444 however: This is a field internally generated by the compiler 6445 for tagged types, and it contains the components inherited from 6446 the parent type. This field should not be printed as is, but 6447 should not be ignored either. */ 6448 if (name[0] == '_' && !startswith (name, "_parent")) 6449 return 1; 6450 } 6451 6452 /* If this is the dispatch table of a tagged type or an interface tag, 6453 then ignore. */ 6454 if (ada_is_tagged_type (type, 1) 6455 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num)) 6456 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num)))) 6457 return 1; 6458 6459 /* Not a special field, so it should not be ignored. */ 6460 return 0; 6461} 6462 6463/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a 6464 pointer or reference type whose ultimate target has a tag field. */ 6465 6466int 6467ada_is_tagged_type (struct type *type, int refok) 6468{ 6469 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL); 6470} 6471 6472/* True iff TYPE represents the type of X'Tag */ 6473 6474int 6475ada_is_tag_type (struct type *type) 6476{ 6477 type = ada_check_typedef (type); 6478 6479 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR) 6480 return 0; 6481 else 6482 { 6483 const char *name = ada_type_name (TYPE_TARGET_TYPE (type)); 6484 6485 return (name != NULL 6486 && strcmp (name, "ada__tags__dispatch_table") == 0); 6487 } 6488} 6489 6490/* The type of the tag on VAL. */ 6491 6492struct type * 6493ada_tag_type (struct value *val) 6494{ 6495 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL); 6496} 6497 6498/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95, 6499 retired at Ada 05). */ 6500 6501static int 6502is_ada95_tag (struct value *tag) 6503{ 6504 return ada_value_struct_elt (tag, "tsd", 1) != NULL; 6505} 6506 6507/* The value of the tag on VAL. */ 6508 6509struct value * 6510ada_value_tag (struct value *val) 6511{ 6512 return ada_value_struct_elt (val, "_tag", 0); 6513} 6514 6515/* The value of the tag on the object of type TYPE whose contents are 6516 saved at VALADDR, if it is non-null, or is at memory address 6517 ADDRESS. */ 6518 6519static struct value * 6520value_tag_from_contents_and_address (struct type *type, 6521 const gdb_byte *valaddr, 6522 CORE_ADDR address) 6523{ 6524 int tag_byte_offset; 6525 struct type *tag_type; 6526 6527 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset, 6528 NULL, NULL, NULL)) 6529 { 6530 const gdb_byte *valaddr1 = ((valaddr == NULL) 6531 ? NULL 6532 : valaddr + tag_byte_offset); 6533 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset; 6534 6535 return value_from_contents_and_address (tag_type, valaddr1, address1); 6536 } 6537 return NULL; 6538} 6539 6540static struct type * 6541type_from_tag (struct value *tag) 6542{ 6543 const char *type_name = ada_tag_name (tag); 6544 6545 if (type_name != NULL) 6546 return ada_find_any_type (ada_encode (type_name)); 6547 return NULL; 6548} 6549 6550/* Given a value OBJ of a tagged type, return a value of this 6551 type at the base address of the object. The base address, as 6552 defined in Ada.Tags, it is the address of the primary tag of 6553 the object, and therefore where the field values of its full 6554 view can be fetched. */ 6555 6556struct value * 6557ada_tag_value_at_base_address (struct value *obj) 6558{ 6559 struct value *val; 6560 LONGEST offset_to_top = 0; 6561 struct type *ptr_type, *obj_type; 6562 struct value *tag; 6563 CORE_ADDR base_address; 6564 6565 obj_type = value_type (obj); 6566 6567 /* It is the responsability of the caller to deref pointers. */ 6568 6569 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR 6570 || TYPE_CODE (obj_type) == TYPE_CODE_REF) 6571 return obj; 6572 6573 tag = ada_value_tag (obj); 6574 if (!tag) 6575 return obj; 6576 6577 /* Base addresses only appeared with Ada 05 and multiple inheritance. */ 6578 6579 if (is_ada95_tag (tag)) 6580 return obj; 6581 6582 ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr; 6583 ptr_type = lookup_pointer_type (ptr_type); 6584 val = value_cast (ptr_type, tag); 6585 if (!val) 6586 return obj; 6587 6588 /* It is perfectly possible that an exception be raised while 6589 trying to determine the base address, just like for the tag; 6590 see ada_tag_name for more details. We do not print the error 6591 message for the same reason. */ 6592 6593 TRY 6594 { 6595 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2))); 6596 } 6597 6598 CATCH (e, RETURN_MASK_ERROR) 6599 { 6600 return obj; 6601 } 6602 END_CATCH 6603 6604 /* If offset is null, nothing to do. */ 6605 6606 if (offset_to_top == 0) 6607 return obj; 6608 6609 /* -1 is a special case in Ada.Tags; however, what should be done 6610 is not quite clear from the documentation. So do nothing for 6611 now. */ 6612 6613 if (offset_to_top == -1) 6614 return obj; 6615 6616 base_address = value_address (obj) - offset_to_top; 6617 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address); 6618 6619 /* Make sure that we have a proper tag at the new address. 6620 Otherwise, offset_to_top is bogus (which can happen when 6621 the object is not initialized yet). */ 6622 6623 if (!tag) 6624 return obj; 6625 6626 obj_type = type_from_tag (tag); 6627 6628 if (!obj_type) 6629 return obj; 6630 6631 return value_from_contents_and_address (obj_type, NULL, base_address); 6632} 6633 6634/* Return the "ada__tags__type_specific_data" type. */ 6635 6636static struct type * 6637ada_get_tsd_type (struct inferior *inf) 6638{ 6639 struct ada_inferior_data *data = get_ada_inferior_data (inf); 6640 6641 if (data->tsd_type == 0) 6642 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data"); 6643 return data->tsd_type; 6644} 6645 6646/* Return the TSD (type-specific data) associated to the given TAG. 6647 TAG is assumed to be the tag of a tagged-type entity. 6648 6649 May return NULL if we are unable to get the TSD. */ 6650 6651static struct value * 6652ada_get_tsd_from_tag (struct value *tag) 6653{ 6654 struct value *val; 6655 struct type *type; 6656 6657 /* First option: The TSD is simply stored as a field of our TAG. 6658 Only older versions of GNAT would use this format, but we have 6659 to test it first, because there are no visible markers for 6660 the current approach except the absence of that field. */ 6661 6662 val = ada_value_struct_elt (tag, "tsd", 1); 6663 if (val) 6664 return val; 6665 6666 /* Try the second representation for the dispatch table (in which 6667 there is no explicit 'tsd' field in the referent of the tag pointer, 6668 and instead the tsd pointer is stored just before the dispatch 6669 table. */ 6670 6671 type = ada_get_tsd_type (current_inferior()); 6672 if (type == NULL) 6673 return NULL; 6674 type = lookup_pointer_type (lookup_pointer_type (type)); 6675 val = value_cast (type, tag); 6676 if (val == NULL) 6677 return NULL; 6678 return value_ind (value_ptradd (val, -1)); 6679} 6680 6681/* Given the TSD of a tag (type-specific data), return a string 6682 containing the name of the associated type. 6683 6684 The returned value is good until the next call. May return NULL 6685 if we are unable to determine the tag name. */ 6686 6687static char * 6688ada_tag_name_from_tsd (struct value *tsd) 6689{ 6690 static char name[1024]; 6691 char *p; 6692 struct value *val; 6693 6694 val = ada_value_struct_elt (tsd, "expanded_name", 1); 6695 if (val == NULL) 6696 return NULL; 6697 read_memory_string (value_as_address (val), name, sizeof (name) - 1); 6698 for (p = name; *p != '\0'; p += 1) 6699 if (isalpha (*p)) 6700 *p = tolower (*p); 6701 return name; 6702} 6703 6704/* The type name of the dynamic type denoted by the 'tag value TAG, as 6705 a C string. 6706 6707 Return NULL if the TAG is not an Ada tag, or if we were unable to 6708 determine the name of that tag. The result is good until the next 6709 call. */ 6710 6711const char * 6712ada_tag_name (struct value *tag) 6713{ 6714 char *name = NULL; 6715 6716 if (!ada_is_tag_type (value_type (tag))) 6717 return NULL; 6718 6719 /* It is perfectly possible that an exception be raised while trying 6720 to determine the TAG's name, even under normal circumstances: 6721 The associated variable may be uninitialized or corrupted, for 6722 instance. We do not let any exception propagate past this point. 6723 instead we return NULL. 6724 6725 We also do not print the error message either (which often is very 6726 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let 6727 the caller print a more meaningful message if necessary. */ 6728 TRY 6729 { 6730 struct value *tsd = ada_get_tsd_from_tag (tag); 6731 6732 if (tsd != NULL) 6733 name = ada_tag_name_from_tsd (tsd); 6734 } 6735 CATCH (e, RETURN_MASK_ERROR) 6736 { 6737 } 6738 END_CATCH 6739 6740 return name; 6741} 6742 6743/* The parent type of TYPE, or NULL if none. */ 6744 6745struct type * 6746ada_parent_type (struct type *type) 6747{ 6748 int i; 6749 6750 type = ada_check_typedef (type); 6751 6752 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT) 6753 return NULL; 6754 6755 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 6756 if (ada_is_parent_field (type, i)) 6757 { 6758 struct type *parent_type = TYPE_FIELD_TYPE (type, i); 6759 6760 /* If the _parent field is a pointer, then dereference it. */ 6761 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR) 6762 parent_type = TYPE_TARGET_TYPE (parent_type); 6763 /* If there is a parallel XVS type, get the actual base type. */ 6764 parent_type = ada_get_base_type (parent_type); 6765 6766 return ada_check_typedef (parent_type); 6767 } 6768 6769 return NULL; 6770} 6771 6772/* True iff field number FIELD_NUM of structure type TYPE contains the 6773 parent-type (inherited) fields of a derived type. Assumes TYPE is 6774 a structure type with at least FIELD_NUM+1 fields. */ 6775 6776int 6777ada_is_parent_field (struct type *type, int field_num) 6778{ 6779 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num); 6780 6781 return (name != NULL 6782 && (startswith (name, "PARENT") 6783 || startswith (name, "_parent"))); 6784} 6785 6786/* True iff field number FIELD_NUM of structure type TYPE is a 6787 transparent wrapper field (which should be silently traversed when doing 6788 field selection and flattened when printing). Assumes TYPE is a 6789 structure type with at least FIELD_NUM+1 fields. Such fields are always 6790 structures. */ 6791 6792int 6793ada_is_wrapper_field (struct type *type, int field_num) 6794{ 6795 const char *name = TYPE_FIELD_NAME (type, field_num); 6796 6797 return (name != NULL 6798 && (startswith (name, "PARENT") 6799 || strcmp (name, "REP") == 0 6800 || startswith (name, "_parent") 6801 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O')); 6802} 6803 6804/* True iff field number FIELD_NUM of structure or union type TYPE 6805 is a variant wrapper. Assumes TYPE is a structure type with at least 6806 FIELD_NUM+1 fields. */ 6807 6808int 6809ada_is_variant_part (struct type *type, int field_num) 6810{ 6811 struct type *field_type = TYPE_FIELD_TYPE (type, field_num); 6812 6813 return (TYPE_CODE (field_type) == TYPE_CODE_UNION 6814 || (is_dynamic_field (type, field_num) 6815 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type)) 6816 == TYPE_CODE_UNION))); 6817} 6818 6819/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part) 6820 whose discriminants are contained in the record type OUTER_TYPE, 6821 returns the type of the controlling discriminant for the variant. 6822 May return NULL if the type could not be found. */ 6823 6824struct type * 6825ada_variant_discrim_type (struct type *var_type, struct type *outer_type) 6826{ 6827 char *name = ada_variant_discrim_name (var_type); 6828 6829 return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL); 6830} 6831 6832/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a 6833 valid field number within it, returns 1 iff field FIELD_NUM of TYPE 6834 represents a 'when others' clause; otherwise 0. */ 6835 6836int 6837ada_is_others_clause (struct type *type, int field_num) 6838{ 6839 const char *name = TYPE_FIELD_NAME (type, field_num); 6840 6841 return (name != NULL && name[0] == 'O'); 6842} 6843 6844/* Assuming that TYPE0 is the type of the variant part of a record, 6845 returns the name of the discriminant controlling the variant. 6846 The value is valid until the next call to ada_variant_discrim_name. */ 6847 6848char * 6849ada_variant_discrim_name (struct type *type0) 6850{ 6851 static char *result = NULL; 6852 static size_t result_len = 0; 6853 struct type *type; 6854 const char *name; 6855 const char *discrim_end; 6856 const char *discrim_start; 6857 6858 if (TYPE_CODE (type0) == TYPE_CODE_PTR) 6859 type = TYPE_TARGET_TYPE (type0); 6860 else 6861 type = type0; 6862 6863 name = ada_type_name (type); 6864 6865 if (name == NULL || name[0] == '\000') 6866 return ""; 6867 6868 for (discrim_end = name + strlen (name) - 6; discrim_end != name; 6869 discrim_end -= 1) 6870 { 6871 if (startswith (discrim_end, "___XVN")) 6872 break; 6873 } 6874 if (discrim_end == name) 6875 return ""; 6876 6877 for (discrim_start = discrim_end; discrim_start != name + 3; 6878 discrim_start -= 1) 6879 { 6880 if (discrim_start == name + 1) 6881 return ""; 6882 if ((discrim_start > name + 3 6883 && startswith (discrim_start - 3, "___")) 6884 || discrim_start[-1] == '.') 6885 break; 6886 } 6887 6888 GROW_VECT (result, result_len, discrim_end - discrim_start + 1); 6889 strncpy (result, discrim_start, discrim_end - discrim_start); 6890 result[discrim_end - discrim_start] = '\0'; 6891 return result; 6892} 6893 6894/* Scan STR for a subtype-encoded number, beginning at position K. 6895 Put the position of the character just past the number scanned in 6896 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. 6897 Return 1 if there was a valid number at the given position, and 0 6898 otherwise. A "subtype-encoded" number consists of the absolute value 6899 in decimal, followed by the letter 'm' to indicate a negative number. 6900 Assumes 0m does not occur. */ 6901 6902int 6903ada_scan_number (const char str[], int k, LONGEST * R, int *new_k) 6904{ 6905 ULONGEST RU; 6906 6907 if (!isdigit (str[k])) 6908 return 0; 6909 6910 /* Do it the hard way so as not to make any assumption about 6911 the relationship of unsigned long (%lu scan format code) and 6912 LONGEST. */ 6913 RU = 0; 6914 while (isdigit (str[k])) 6915 { 6916 RU = RU * 10 + (str[k] - '0'); 6917 k += 1; 6918 } 6919 6920 if (str[k] == 'm') 6921 { 6922 if (R != NULL) 6923 *R = (-(LONGEST) (RU - 1)) - 1; 6924 k += 1; 6925 } 6926 else if (R != NULL) 6927 *R = (LONGEST) RU; 6928 6929 /* NOTE on the above: Technically, C does not say what the results of 6930 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive 6931 number representable as a LONGEST (although either would probably work 6932 in most implementations). When RU>0, the locution in the then branch 6933 above is always equivalent to the negative of RU. */ 6934 6935 if (new_k != NULL) 6936 *new_k = k; 6937 return 1; 6938} 6939 6940/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field), 6941 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is 6942 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */ 6943 6944int 6945ada_in_variant (LONGEST val, struct type *type, int field_num) 6946{ 6947 const char *name = TYPE_FIELD_NAME (type, field_num); 6948 int p; 6949 6950 p = 0; 6951 while (1) 6952 { 6953 switch (name[p]) 6954 { 6955 case '\0': 6956 return 0; 6957 case 'S': 6958 { 6959 LONGEST W; 6960 6961 if (!ada_scan_number (name, p + 1, &W, &p)) 6962 return 0; 6963 if (val == W) 6964 return 1; 6965 break; 6966 } 6967 case 'R': 6968 { 6969 LONGEST L, U; 6970 6971 if (!ada_scan_number (name, p + 1, &L, &p) 6972 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p)) 6973 return 0; 6974 if (val >= L && val <= U) 6975 return 1; 6976 break; 6977 } 6978 case 'O': 6979 return 1; 6980 default: 6981 return 0; 6982 } 6983 } 6984} 6985 6986/* FIXME: Lots of redundancy below. Try to consolidate. */ 6987 6988/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type 6989 ARG_TYPE, extract and return the value of one of its (non-static) 6990 fields. FIELDNO says which field. Differs from value_primitive_field 6991 only in that it can handle packed values of arbitrary type. */ 6992 6993static struct value * 6994ada_value_primitive_field (struct value *arg1, int offset, int fieldno, 6995 struct type *arg_type) 6996{ 6997 struct type *type; 6998 6999 arg_type = ada_check_typedef (arg_type); 7000 type = TYPE_FIELD_TYPE (arg_type, fieldno); 7001 7002 /* Handle packed fields. */ 7003 7004 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0) 7005 { 7006 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno); 7007 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno); 7008 7009 return ada_value_primitive_packed_val (arg1, value_contents (arg1), 7010 offset + bit_pos / 8, 7011 bit_pos % 8, bit_size, type); 7012 } 7013 else 7014 return value_primitive_field (arg1, offset, fieldno, arg_type); 7015} 7016 7017/* Find field with name NAME in object of type TYPE. If found, 7018 set the following for each argument that is non-null: 7019 - *FIELD_TYPE_P to the field's type; 7020 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within 7021 an object of that type; 7022 - *BIT_OFFSET_P to the bit offset modulo byte size of the field; 7023 - *BIT_SIZE_P to its size in bits if the field is packed, and 7024 0 otherwise; 7025 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible 7026 fields up to but not including the desired field, or by the total 7027 number of fields if not found. A NULL value of NAME never 7028 matches; the function just counts visible fields in this case. 7029 7030 Returns 1 if found, 0 otherwise. */ 7031 7032static int 7033find_struct_field (const char *name, struct type *type, int offset, 7034 struct type **field_type_p, 7035 int *byte_offset_p, int *bit_offset_p, int *bit_size_p, 7036 int *index_p) 7037{ 7038 int i; 7039 7040 type = ada_check_typedef (type); 7041 7042 if (field_type_p != NULL) 7043 *field_type_p = NULL; 7044 if (byte_offset_p != NULL) 7045 *byte_offset_p = 0; 7046 if (bit_offset_p != NULL) 7047 *bit_offset_p = 0; 7048 if (bit_size_p != NULL) 7049 *bit_size_p = 0; 7050 7051 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 7052 { 7053 int bit_pos = TYPE_FIELD_BITPOS (type, i); 7054 int fld_offset = offset + bit_pos / 8; 7055 const char *t_field_name = TYPE_FIELD_NAME (type, i); 7056 7057 if (t_field_name == NULL) 7058 continue; 7059 7060 else if (name != NULL && field_name_match (t_field_name, name)) 7061 { 7062 int bit_size = TYPE_FIELD_BITSIZE (type, i); 7063 7064 if (field_type_p != NULL) 7065 *field_type_p = TYPE_FIELD_TYPE (type, i); 7066 if (byte_offset_p != NULL) 7067 *byte_offset_p = fld_offset; 7068 if (bit_offset_p != NULL) 7069 *bit_offset_p = bit_pos % 8; 7070 if (bit_size_p != NULL) 7071 *bit_size_p = bit_size; 7072 return 1; 7073 } 7074 else if (ada_is_wrapper_field (type, i)) 7075 { 7076 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset, 7077 field_type_p, byte_offset_p, bit_offset_p, 7078 bit_size_p, index_p)) 7079 return 1; 7080 } 7081 else if (ada_is_variant_part (type, i)) 7082 { 7083 /* PNH: Wait. Do we ever execute this section, or is ARG always of 7084 fixed type?? */ 7085 int j; 7086 struct type *field_type 7087 = ada_check_typedef (TYPE_FIELD_TYPE (type, i)); 7088 7089 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1) 7090 { 7091 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j), 7092 fld_offset 7093 + TYPE_FIELD_BITPOS (field_type, j) / 8, 7094 field_type_p, byte_offset_p, 7095 bit_offset_p, bit_size_p, index_p)) 7096 return 1; 7097 } 7098 } 7099 else if (index_p != NULL) 7100 *index_p += 1; 7101 } 7102 return 0; 7103} 7104 7105/* Number of user-visible fields in record type TYPE. */ 7106 7107static int 7108num_visible_fields (struct type *type) 7109{ 7110 int n; 7111 7112 n = 0; 7113 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n); 7114 return n; 7115} 7116 7117/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes, 7118 and search in it assuming it has (class) type TYPE. 7119 If found, return value, else return NULL. 7120 7121 Searches recursively through wrapper fields (e.g., '_parent'). */ 7122 7123static struct value * 7124ada_search_struct_field (char *name, struct value *arg, int offset, 7125 struct type *type) 7126{ 7127 int i; 7128 7129 type = ada_check_typedef (type); 7130 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 7131 { 7132 const char *t_field_name = TYPE_FIELD_NAME (type, i); 7133 7134 if (t_field_name == NULL) 7135 continue; 7136 7137 else if (field_name_match (t_field_name, name)) 7138 return ada_value_primitive_field (arg, offset, i, type); 7139 7140 else if (ada_is_wrapper_field (type, i)) 7141 { 7142 struct value *v = /* Do not let indent join lines here. */ 7143 ada_search_struct_field (name, arg, 7144 offset + TYPE_FIELD_BITPOS (type, i) / 8, 7145 TYPE_FIELD_TYPE (type, i)); 7146 7147 if (v != NULL) 7148 return v; 7149 } 7150 7151 else if (ada_is_variant_part (type, i)) 7152 { 7153 /* PNH: Do we ever get here? See find_struct_field. */ 7154 int j; 7155 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, 7156 i)); 7157 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8; 7158 7159 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1) 7160 { 7161 struct value *v = ada_search_struct_field /* Force line 7162 break. */ 7163 (name, arg, 7164 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8, 7165 TYPE_FIELD_TYPE (field_type, j)); 7166 7167 if (v != NULL) 7168 return v; 7169 } 7170 } 7171 } 7172 return NULL; 7173} 7174 7175static struct value *ada_index_struct_field_1 (int *, struct value *, 7176 int, struct type *); 7177 7178 7179/* Return field #INDEX in ARG, where the index is that returned by 7180 * find_struct_field through its INDEX_P argument. Adjust the address 7181 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE. 7182 * If found, return value, else return NULL. */ 7183 7184static struct value * 7185ada_index_struct_field (int index, struct value *arg, int offset, 7186 struct type *type) 7187{ 7188 return ada_index_struct_field_1 (&index, arg, offset, type); 7189} 7190 7191 7192/* Auxiliary function for ada_index_struct_field. Like 7193 * ada_index_struct_field, but takes index from *INDEX_P and modifies 7194 * *INDEX_P. */ 7195 7196static struct value * 7197ada_index_struct_field_1 (int *index_p, struct value *arg, int offset, 7198 struct type *type) 7199{ 7200 int i; 7201 type = ada_check_typedef (type); 7202 7203 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 7204 { 7205 if (TYPE_FIELD_NAME (type, i) == NULL) 7206 continue; 7207 else if (ada_is_wrapper_field (type, i)) 7208 { 7209 struct value *v = /* Do not let indent join lines here. */ 7210 ada_index_struct_field_1 (index_p, arg, 7211 offset + TYPE_FIELD_BITPOS (type, i) / 8, 7212 TYPE_FIELD_TYPE (type, i)); 7213 7214 if (v != NULL) 7215 return v; 7216 } 7217 7218 else if (ada_is_variant_part (type, i)) 7219 { 7220 /* PNH: Do we ever get here? See ada_search_struct_field, 7221 find_struct_field. */ 7222 error (_("Cannot assign this kind of variant record")); 7223 } 7224 else if (*index_p == 0) 7225 return ada_value_primitive_field (arg, offset, i, type); 7226 else 7227 *index_p -= 1; 7228 } 7229 return NULL; 7230} 7231 7232/* Given ARG, a value of type (pointer or reference to a)* 7233 structure/union, extract the component named NAME from the ultimate 7234 target structure/union and return it as a value with its 7235 appropriate type. 7236 7237 The routine searches for NAME among all members of the structure itself 7238 and (recursively) among all members of any wrapper members 7239 (e.g., '_parent'). 7240 7241 If NO_ERR, then simply return NULL in case of error, rather than 7242 calling error. */ 7243 7244struct value * 7245ada_value_struct_elt (struct value *arg, char *name, int no_err) 7246{ 7247 struct type *t, *t1; 7248 struct value *v; 7249 7250 v = NULL; 7251 t1 = t = ada_check_typedef (value_type (arg)); 7252 if (TYPE_CODE (t) == TYPE_CODE_REF) 7253 { 7254 t1 = TYPE_TARGET_TYPE (t); 7255 if (t1 == NULL) 7256 goto BadValue; 7257 t1 = ada_check_typedef (t1); 7258 if (TYPE_CODE (t1) == TYPE_CODE_PTR) 7259 { 7260 arg = coerce_ref (arg); 7261 t = t1; 7262 } 7263 } 7264 7265 while (TYPE_CODE (t) == TYPE_CODE_PTR) 7266 { 7267 t1 = TYPE_TARGET_TYPE (t); 7268 if (t1 == NULL) 7269 goto BadValue; 7270 t1 = ada_check_typedef (t1); 7271 if (TYPE_CODE (t1) == TYPE_CODE_PTR) 7272 { 7273 arg = value_ind (arg); 7274 t = t1; 7275 } 7276 else 7277 break; 7278 } 7279 7280 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION) 7281 goto BadValue; 7282 7283 if (t1 == t) 7284 v = ada_search_struct_field (name, arg, 0, t); 7285 else 7286 { 7287 int bit_offset, bit_size, byte_offset; 7288 struct type *field_type; 7289 CORE_ADDR address; 7290 7291 if (TYPE_CODE (t) == TYPE_CODE_PTR) 7292 address = value_address (ada_value_ind (arg)); 7293 else 7294 address = value_address (ada_coerce_ref (arg)); 7295 7296 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1); 7297 if (find_struct_field (name, t1, 0, 7298 &field_type, &byte_offset, &bit_offset, 7299 &bit_size, NULL)) 7300 { 7301 if (bit_size != 0) 7302 { 7303 if (TYPE_CODE (t) == TYPE_CODE_REF) 7304 arg = ada_coerce_ref (arg); 7305 else 7306 arg = ada_value_ind (arg); 7307 v = ada_value_primitive_packed_val (arg, NULL, byte_offset, 7308 bit_offset, bit_size, 7309 field_type); 7310 } 7311 else 7312 v = value_at_lazy (field_type, address + byte_offset); 7313 } 7314 } 7315 7316 if (v != NULL || no_err) 7317 return v; 7318 else 7319 error (_("There is no member named %s."), name); 7320 7321 BadValue: 7322 if (no_err) 7323 return NULL; 7324 else 7325 error (_("Attempt to extract a component of " 7326 "a value that is not a record.")); 7327} 7328 7329/* Given a type TYPE, look up the type of the component of type named NAME. 7330 If DISPP is non-null, add its byte displacement from the beginning of a 7331 structure (pointed to by a value) of type TYPE to *DISPP (does not 7332 work for packed fields). 7333 7334 Matches any field whose name has NAME as a prefix, possibly 7335 followed by "___". 7336 7337 TYPE can be either a struct or union. If REFOK, TYPE may also 7338 be a (pointer or reference)+ to a struct or union, and the 7339 ultimate target type will be searched. 7340 7341 Looks recursively into variant clauses and parent types. 7342 7343 If NOERR is nonzero, return NULL if NAME is not suitably defined or 7344 TYPE is not a type of the right kind. */ 7345 7346static struct type * 7347ada_lookup_struct_elt_type (struct type *type, char *name, int refok, 7348 int noerr, int *dispp) 7349{ 7350 int i; 7351 7352 if (name == NULL) 7353 goto BadName; 7354 7355 if (refok && type != NULL) 7356 while (1) 7357 { 7358 type = ada_check_typedef (type); 7359 if (TYPE_CODE (type) != TYPE_CODE_PTR 7360 && TYPE_CODE (type) != TYPE_CODE_REF) 7361 break; 7362 type = TYPE_TARGET_TYPE (type); 7363 } 7364 7365 if (type == NULL 7366 || (TYPE_CODE (type) != TYPE_CODE_STRUCT 7367 && TYPE_CODE (type) != TYPE_CODE_UNION)) 7368 { 7369 if (noerr) 7370 return NULL; 7371 else 7372 { 7373 target_terminal_ours (); 7374 gdb_flush (gdb_stdout); 7375 if (type == NULL) 7376 error (_("Type (null) is not a structure or union type")); 7377 else 7378 { 7379 /* XXX: type_sprint */ 7380 fprintf_unfiltered (gdb_stderr, _("Type ")); 7381 type_print (type, "", gdb_stderr, -1); 7382 error (_(" is not a structure or union type")); 7383 } 7384 } 7385 } 7386 7387 type = to_static_fixed_type (type); 7388 7389 for (i = 0; i < TYPE_NFIELDS (type); i += 1) 7390 { 7391 const char *t_field_name = TYPE_FIELD_NAME (type, i); 7392 struct type *t; 7393 int disp; 7394 7395 if (t_field_name == NULL) 7396 continue; 7397 7398 else if (field_name_match (t_field_name, name)) 7399 { 7400 if (dispp != NULL) 7401 *dispp += TYPE_FIELD_BITPOS (type, i) / 8; 7402 return TYPE_FIELD_TYPE (type, i); 7403 } 7404 7405 else if (ada_is_wrapper_field (type, i)) 7406 { 7407 disp = 0; 7408 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name, 7409 0, 1, &disp); 7410 if (t != NULL) 7411 { 7412 if (dispp != NULL) 7413 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8; 7414 return t; 7415 } 7416 } 7417 7418 else if (ada_is_variant_part (type, i)) 7419 { 7420 int j; 7421 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, 7422 i)); 7423 7424 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1) 7425 { 7426 /* FIXME pnh 2008/01/26: We check for a field that is 7427 NOT wrapped in a struct, since the compiler sometimes 7428 generates these for unchecked variant types. Revisit 7429 if the compiler changes this practice. */ 7430 const char *v_field_name = TYPE_FIELD_NAME (field_type, j); 7431 disp = 0; 7432 if (v_field_name != NULL 7433 && field_name_match (v_field_name, name)) 7434 t = TYPE_FIELD_TYPE (field_type, j); 7435 else 7436 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, 7437 j), 7438 name, 0, 1, &disp); 7439 7440 if (t != NULL) 7441 { 7442 if (dispp != NULL) 7443 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8; 7444 return t; 7445 } 7446 } 7447 } 7448 7449 } 7450 7451BadName: 7452 if (!noerr) 7453 { 7454 target_terminal_ours (); 7455 gdb_flush (gdb_stdout); 7456 if (name == NULL) 7457 { 7458 /* XXX: type_sprint */ 7459 fprintf_unfiltered (gdb_stderr, _("Type ")); 7460 type_print (type, "", gdb_stderr, -1); 7461 error (_(" has no component named <null>")); 7462 } 7463 else 7464 { 7465 /* XXX: type_sprint */ 7466 fprintf_unfiltered (gdb_stderr, _("Type ")); 7467 type_print (type, "", gdb_stderr, -1); 7468 error (_(" has no component named %s"), name); 7469 } 7470 } 7471 7472 return NULL; 7473} 7474 7475/* Assuming that VAR_TYPE is the type of a variant part of a record (a union), 7476 within a value of type OUTER_TYPE, return true iff VAR_TYPE 7477 represents an unchecked union (that is, the variant part of a 7478 record that is named in an Unchecked_Union pragma). */ 7479 7480static int 7481is_unchecked_variant (struct type *var_type, struct type *outer_type) 7482{ 7483 char *discrim_name = ada_variant_discrim_name (var_type); 7484 7485 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL) 7486 == NULL); 7487} 7488 7489 7490/* Assuming that VAR_TYPE is the type of a variant part of a record (a union), 7491 within a value of type OUTER_TYPE that is stored in GDB at 7492 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE, 7493 numbering from 0) is applicable. Returns -1 if none are. */ 7494 7495int 7496ada_which_variant_applies (struct type *var_type, struct type *outer_type, 7497 const gdb_byte *outer_valaddr) 7498{ 7499 int others_clause; 7500 int i; 7501 char *discrim_name = ada_variant_discrim_name (var_type); 7502 struct value *outer; 7503 struct value *discrim; 7504 LONGEST discrim_val; 7505 7506 /* Using plain value_from_contents_and_address here causes problems 7507 because we will end up trying to resolve a type that is currently 7508 being constructed. */ 7509 outer = value_from_contents_and_address_unresolved (outer_type, 7510 outer_valaddr, 0); 7511 discrim = ada_value_struct_elt (outer, discrim_name, 1); 7512 if (discrim == NULL) 7513 return -1; 7514 discrim_val = value_as_long (discrim); 7515 7516 others_clause = -1; 7517 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1) 7518 { 7519 if (ada_is_others_clause (var_type, i)) 7520 others_clause = i; 7521 else if (ada_in_variant (discrim_val, var_type, i)) 7522 return i; 7523 } 7524 7525 return others_clause; 7526} 7527 7528 7529 7530 /* Dynamic-Sized Records */ 7531 7532/* Strategy: The type ostensibly attached to a value with dynamic size 7533 (i.e., a size that is not statically recorded in the debugging 7534 data) does not accurately reflect the size or layout of the value. 7535 Our strategy is to convert these values to values with accurate, 7536 conventional types that are constructed on the fly. */ 7537 7538/* There is a subtle and tricky problem here. In general, we cannot 7539 determine the size of dynamic records without its data. However, 7540 the 'struct value' data structure, which GDB uses to represent 7541 quantities in the inferior process (the target), requires the size 7542 of the type at the time of its allocation in order to reserve space 7543 for GDB's internal copy of the data. That's why the 7544 'to_fixed_xxx_type' routines take (target) addresses as parameters, 7545 rather than struct value*s. 7546 7547 However, GDB's internal history variables ($1, $2, etc.) are 7548 struct value*s containing internal copies of the data that are not, in 7549 general, the same as the data at their corresponding addresses in 7550 the target. Fortunately, the types we give to these values are all 7551 conventional, fixed-size types (as per the strategy described 7552 above), so that we don't usually have to perform the 7553 'to_fixed_xxx_type' conversions to look at their values. 7554 Unfortunately, there is one exception: if one of the internal 7555 history variables is an array whose elements are unconstrained 7556 records, then we will need to create distinct fixed types for each 7557 element selected. */ 7558 7559/* The upshot of all of this is that many routines take a (type, host 7560 address, target address) triple as arguments to represent a value. 7561 The host address, if non-null, is supposed to contain an internal 7562 copy of the relevant data; otherwise, the program is to consult the 7563 target at the target address. */ 7564 7565/* Assuming that VAL0 represents a pointer value, the result of 7566 dereferencing it. Differs from value_ind in its treatment of 7567 dynamic-sized types. */ 7568 7569struct value * 7570ada_value_ind (struct value *val0) 7571{ 7572 struct value *val = value_ind (val0); 7573 7574 if (ada_is_tagged_type (value_type (val), 0)) 7575 val = ada_tag_value_at_base_address (val); 7576 7577 return ada_to_fixed_value (val); 7578} 7579 7580/* The value resulting from dereferencing any "reference to" 7581 qualifiers on VAL0. */ 7582 7583static struct value * 7584ada_coerce_ref (struct value *val0) 7585{ 7586 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF) 7587 { 7588 struct value *val = val0; 7589 7590 val = coerce_ref (val); 7591 7592 if (ada_is_tagged_type (value_type (val), 0)) 7593 val = ada_tag_value_at_base_address (val); 7594 7595 return ada_to_fixed_value (val); 7596 } 7597 else 7598 return val0; 7599} 7600 7601/* Return OFF rounded upward if necessary to a multiple of 7602 ALIGNMENT (a power of 2). */ 7603 7604static unsigned int 7605align_value (unsigned int off, unsigned int alignment) 7606{ 7607 return (off + alignment - 1) & ~(alignment - 1); 7608} 7609 7610/* Return the bit alignment required for field #F of template type TYPE. */ 7611 7612static unsigned int 7613field_alignment (struct type *type, int f) 7614{ 7615 const char *name = TYPE_FIELD_NAME (type, f); 7616 int len; 7617 int align_offset; 7618 7619 /* The field name should never be null, unless the debugging information 7620 is somehow malformed. In this case, we assume the field does not 7621 require any alignment. */ 7622 if (name == NULL) 7623 return 1; 7624 7625 len = strlen (name); 7626 7627 if (!isdigit (name[len - 1])) 7628 return 1; 7629 7630 if (isdigit (name[len - 2])) 7631 align_offset = len - 2; 7632 else 7633 align_offset = len - 1; 7634 7635 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV")) 7636 return TARGET_CHAR_BIT; 7637 7638 return atoi (name + align_offset) * TARGET_CHAR_BIT; 7639} 7640 7641/* Find a typedef or tag symbol named NAME. Ignores ambiguity. */ 7642 7643static struct symbol * 7644ada_find_any_type_symbol (const char *name) 7645{ 7646 struct symbol *sym; 7647 7648 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN); 7649 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF) 7650 return sym; 7651 7652 sym = standard_lookup (name, NULL, STRUCT_DOMAIN); 7653 return sym; 7654} 7655 7656/* Find a type named NAME. Ignores ambiguity. This routine will look 7657 solely for types defined by debug info, it will not search the GDB 7658 primitive types. */ 7659 7660static struct type * 7661ada_find_any_type (const char *name) 7662{ 7663 struct symbol *sym = ada_find_any_type_symbol (name); 7664 7665 if (sym != NULL) 7666 return SYMBOL_TYPE (sym); 7667 7668 return NULL; 7669} 7670 7671/* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol 7672 associated with NAME_SYM's name. NAME_SYM may itself be a renaming 7673 symbol, in which case it is returned. Otherwise, this looks for 7674 symbols whose name is that of NAME_SYM suffixed with "___XR". 7675 Return symbol if found, and NULL otherwise. */ 7676 7677struct symbol * 7678ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block) 7679{ 7680 const char *name = SYMBOL_LINKAGE_NAME (name_sym); 7681 struct symbol *sym; 7682 7683 if (strstr (name, "___XR") != NULL) 7684 return name_sym; 7685 7686 sym = find_old_style_renaming_symbol (name, block); 7687 7688 if (sym != NULL) 7689 return sym; 7690 7691 /* Not right yet. FIXME pnh 7/20/2007. */ 7692 sym = ada_find_any_type_symbol (name); 7693 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL) 7694 return sym; 7695 else 7696 return NULL; 7697} 7698 7699static struct symbol * 7700find_old_style_renaming_symbol (const char *name, const struct block *block) 7701{ 7702 const struct symbol *function_sym = block_linkage_function (block); 7703 char *rename; 7704 7705 if (function_sym != NULL) 7706 { 7707 /* If the symbol is defined inside a function, NAME is not fully 7708 qualified. This means we need to prepend the function name 7709 as well as adding the ``___XR'' suffix to build the name of 7710 the associated renaming symbol. */ 7711 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym); 7712 /* Function names sometimes contain suffixes used 7713 for instance to qualify nested subprograms. When building 7714 the XR type name, we need to make sure that this suffix is 7715 not included. So do not include any suffix in the function 7716 name length below. */ 7717 int function_name_len = ada_name_prefix_len (function_name); 7718 const int rename_len = function_name_len + 2 /* "__" */ 7719 + strlen (name) + 6 /* "___XR\0" */ ; 7720 7721 /* Strip the suffix if necessary. */ 7722 ada_remove_trailing_digits (function_name, &function_name_len); 7723 ada_remove_po_subprogram_suffix (function_name, &function_name_len); 7724 ada_remove_Xbn_suffix (function_name, &function_name_len); 7725 7726 /* Library-level functions are a special case, as GNAT adds 7727 a ``_ada_'' prefix to the function name to avoid namespace 7728 pollution. However, the renaming symbols themselves do not 7729 have this prefix, so we need to skip this prefix if present. */ 7730 if (function_name_len > 5 /* "_ada_" */ 7731 && strstr (function_name, "_ada_") == function_name) 7732 { 7733 function_name += 5; 7734 function_name_len -= 5; 7735 } 7736 7737 rename = (char *) alloca (rename_len * sizeof (char)); 7738 strncpy (rename, function_name, function_name_len); 7739 xsnprintf (rename + function_name_len, rename_len - function_name_len, 7740 "__%s___XR", name); 7741 } 7742 else 7743 { 7744 const int rename_len = strlen (name) + 6; 7745 7746 rename = (char *) alloca (rename_len * sizeof (char)); 7747 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name); 7748 } 7749 7750 return ada_find_any_type_symbol (rename); 7751} 7752 7753/* Because of GNAT encoding conventions, several GDB symbols may match a 7754 given type name. If the type denoted by TYPE0 is to be preferred to 7755 that of TYPE1 for purposes of type printing, return non-zero; 7756 otherwise return 0. */ 7757 7758int 7759ada_prefer_type (struct type *type0, struct type *type1) 7760{ 7761 if (type1 == NULL) 7762 return 1; 7763 else if (type0 == NULL) 7764 return 0; 7765 else if (TYPE_CODE (type1) == TYPE_CODE_VOID) 7766 return 1; 7767 else if (TYPE_CODE (type0) == TYPE_CODE_VOID) 7768 return 0; 7769 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL) 7770 return 1; 7771 else if (ada_is_constrained_packed_array_type (type0)) 7772 return 1; 7773 else if (ada_is_array_descriptor_type (type0) 7774 && !ada_is_array_descriptor_type (type1)) 7775 return 1; 7776 else 7777 { 7778 const char *type0_name = type_name_no_tag (type0); 7779 const char *type1_name = type_name_no_tag (type1); 7780 7781 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL 7782 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL)) 7783 return 1; 7784 } 7785 return 0; 7786} 7787 7788/* The name of TYPE, which is either its TYPE_NAME, or, if that is 7789 null, its TYPE_TAG_NAME. Null if TYPE is null. */ 7790 7791const char * 7792ada_type_name (struct type *type) 7793{ 7794 if (type == NULL) 7795 return NULL; 7796 else if (TYPE_NAME (type) != NULL) 7797 return TYPE_NAME (type); 7798 else 7799 return TYPE_TAG_NAME (type); 7800} 7801 7802/* Search the list of "descriptive" types associated to TYPE for a type 7803 whose name is NAME. */ 7804 7805static struct type * 7806find_parallel_type_by_descriptive_type (struct type *type, const char *name) 7807{ 7808 struct type *result, *tmp; 7809 7810 if (ada_ignore_descriptive_types_p) 7811 return NULL; 7812 7813 /* If there no descriptive-type info, then there is no parallel type 7814 to be found. */ 7815 if (!HAVE_GNAT_AUX_INFO (type)) 7816 return NULL; 7817 7818 result = TYPE_DESCRIPTIVE_TYPE (type); 7819 while (result != NULL) 7820 { 7821 const char *result_name = ada_type_name (result); 7822 7823 if (result_name == NULL) 7824 { 7825 warning (_("unexpected null name on descriptive type")); 7826 return NULL; 7827 } 7828 7829 /* If the names match, stop. */ 7830 if (strcmp (result_name, name) == 0) 7831 break; 7832 7833 /* Otherwise, look at the next item on the list, if any. */ 7834 if (HAVE_GNAT_AUX_INFO (result)) 7835 tmp = TYPE_DESCRIPTIVE_TYPE (result); 7836 else 7837 tmp = NULL; 7838 7839 /* If not found either, try after having resolved the typedef. */ 7840 if (tmp != NULL) 7841 result = tmp; 7842 else 7843 { 7844 CHECK_TYPEDEF (result); 7845 if (HAVE_GNAT_AUX_INFO (result)) 7846 result = TYPE_DESCRIPTIVE_TYPE (result); 7847 else 7848 result = NULL; 7849 } 7850 } 7851 7852 /* If we didn't find a match, see whether this is a packed array. With 7853 older compilers, the descriptive type information is either absent or 7854 irrelevant when it comes to packed arrays so the above lookup fails. 7855 Fall back to using a parallel lookup by name in this case. */ 7856 if (result == NULL && ada_is_constrained_packed_array_type (type)) 7857 return ada_find_any_type (name); 7858 7859 return result; 7860} 7861 7862/* Find a parallel type to TYPE with the specified NAME, using the 7863 descriptive type taken from the debugging information, if available, 7864 and otherwise using the (slower) name-based method. */ 7865 7866static struct type * 7867ada_find_parallel_type_with_name (struct type *type, const char *name) 7868{ 7869 struct type *result = NULL; 7870 7871 if (HAVE_GNAT_AUX_INFO (type)) 7872 result = find_parallel_type_by_descriptive_type (type, name); 7873 else 7874 result = ada_find_any_type (name); 7875 7876 return result; 7877} 7878 7879/* Same as above, but specify the name of the parallel type by appending 7880 SUFFIX to the name of TYPE. */ 7881 7882struct type * 7883ada_find_parallel_type (struct type *type, const char *suffix) 7884{ 7885 char *name; 7886 const char *type_name = ada_type_name (type); 7887 int len; 7888 7889 if (type_name == NULL) 7890 return NULL; 7891 7892 len = strlen (type_name); 7893 7894 name = (char *) alloca (len + strlen (suffix) + 1); 7895 7896 strcpy (name, type_name); 7897 strcpy (name + len, suffix); 7898 7899 return ada_find_parallel_type_with_name (type, name); 7900} 7901 7902/* If TYPE is a variable-size record type, return the corresponding template 7903 type describing its fields. Otherwise, return NULL. */ 7904 7905static struct type * 7906dynamic_template_type (struct type *type) 7907{ 7908 type = ada_check_typedef (type); 7909 7910 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT 7911 || ada_type_name (type) == NULL) 7912 return NULL; 7913 else 7914 { 7915 int len = strlen (ada_type_name (type)); 7916 7917 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0) 7918 return type; 7919 else 7920 return ada_find_parallel_type (type, "___XVE"); 7921 } 7922} 7923 7924/* Assuming that TEMPL_TYPE is a union or struct type, returns 7925 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */ 7926 7927static int 7928is_dynamic_field (struct type *templ_type, int field_num) 7929{ 7930 const char *name = TYPE_FIELD_NAME (templ_type, field_num); 7931 7932 return name != NULL 7933 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR 7934 && strstr (name, "___XVL") != NULL; 7935} 7936 7937/* The index of the variant field of TYPE, or -1 if TYPE does not 7938 represent a variant record type. */ 7939 7940static int 7941variant_field_index (struct type *type) 7942{ 7943 int f; 7944 7945 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT) 7946 return -1; 7947 7948 for (f = 0; f < TYPE_NFIELDS (type); f += 1) 7949 { 7950 if (ada_is_variant_part (type, f)) 7951 return f; 7952 } 7953 return -1; 7954} 7955 7956/* A record type with no fields. */ 7957 7958static struct type * 7959empty_record (struct type *templ) 7960{ 7961 struct type *type = alloc_type_copy (templ); 7962 7963 TYPE_CODE (type) = TYPE_CODE_STRUCT; 7964 TYPE_NFIELDS (type) = 0; 7965 TYPE_FIELDS (type) = NULL; 7966 INIT_CPLUS_SPECIFIC (type); 7967 TYPE_NAME (type) = "<empty>"; 7968 TYPE_TAG_NAME (type) = NULL; 7969 TYPE_LENGTH (type) = 0; 7970 return type; 7971} 7972 7973/* An ordinary record type (with fixed-length fields) that describes 7974 the value of type TYPE at VALADDR or ADDRESS (see comments at 7975 the beginning of this section) VAL according to GNAT conventions. 7976 DVAL0 should describe the (portion of a) record that contains any 7977 necessary discriminants. It should be NULL if value_type (VAL) is 7978 an outer-level type (i.e., as opposed to a branch of a variant.) A 7979 variant field (unless unchecked) is replaced by a particular branch 7980 of the variant. 7981 7982 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or 7983 length are not statically known are discarded. As a consequence, 7984 VALADDR, ADDRESS and DVAL0 are ignored. 7985 7986 NOTE: Limitations: For now, we assume that dynamic fields and 7987 variants occupy whole numbers of bytes. However, they need not be 7988 byte-aligned. */ 7989 7990struct type * 7991ada_template_to_fixed_record_type_1 (struct type *type, 7992 const gdb_byte *valaddr, 7993 CORE_ADDR address, struct value *dval0, 7994 int keep_dynamic_fields) 7995{ 7996 struct value *mark = value_mark (); 7997 struct value *dval; 7998 struct type *rtype; 7999 int nfields, bit_len; 8000 int variant_field; 8001 long off; 8002 int fld_bit_len; 8003 int f; 8004 8005 /* Compute the number of fields in this record type that are going 8006 to be processed: unless keep_dynamic_fields, this includes only 8007 fields whose position and length are static will be processed. */ 8008 if (keep_dynamic_fields) 8009 nfields = TYPE_NFIELDS (type); 8010 else 8011 { 8012 nfields = 0; 8013 while (nfields < TYPE_NFIELDS (type) 8014 && !ada_is_variant_part (type, nfields) 8015 && !is_dynamic_field (type, nfields)) 8016 nfields++; 8017 } 8018 8019 rtype = alloc_type_copy (type); 8020 TYPE_CODE (rtype) = TYPE_CODE_STRUCT; 8021 INIT_CPLUS_SPECIFIC (rtype); 8022 TYPE_NFIELDS (rtype) = nfields; 8023 TYPE_FIELDS (rtype) = (struct field *) 8024 TYPE_ALLOC (rtype, nfields * sizeof (struct field)); 8025 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields); 8026 TYPE_NAME (rtype) = ada_type_name (type); 8027 TYPE_TAG_NAME (rtype) = NULL; 8028 TYPE_FIXED_INSTANCE (rtype) = 1; 8029 8030 off = 0; 8031 bit_len = 0; 8032 variant_field = -1; 8033 8034 for (f = 0; f < nfields; f += 1) 8035 { 8036 off = align_value (off, field_alignment (type, f)) 8037 + TYPE_FIELD_BITPOS (type, f); 8038 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off); 8039 TYPE_FIELD_BITSIZE (rtype, f) = 0; 8040 8041 if (ada_is_variant_part (type, f)) 8042 { 8043 variant_field = f; 8044 fld_bit_len = 0; 8045 } 8046 else if (is_dynamic_field (type, f)) 8047 { 8048 const gdb_byte *field_valaddr = valaddr; 8049 CORE_ADDR field_address = address; 8050 struct type *field_type = 8051 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f)); 8052 8053 if (dval0 == NULL) 8054 { 8055 /* rtype's length is computed based on the run-time 8056 value of discriminants. If the discriminants are not 8057 initialized, the type size may be completely bogus and 8058 GDB may fail to allocate a value for it. So check the 8059 size first before creating the value. */ 8060 ada_ensure_varsize_limit (rtype); 8061 /* Using plain value_from_contents_and_address here 8062 causes problems because we will end up trying to 8063 resolve a type that is currently being 8064 constructed. */ 8065 dval = value_from_contents_and_address_unresolved (rtype, 8066 valaddr, 8067 address); 8068 rtype = value_type (dval); 8069 } 8070 else 8071 dval = dval0; 8072 8073 /* If the type referenced by this field is an aligner type, we need 8074 to unwrap that aligner type, because its size might not be set. 8075 Keeping the aligner type would cause us to compute the wrong 8076 size for this field, impacting the offset of the all the fields 8077 that follow this one. */ 8078 if (ada_is_aligner_type (field_type)) 8079 { 8080 long field_offset = TYPE_FIELD_BITPOS (field_type, f); 8081 8082 field_valaddr = cond_offset_host (field_valaddr, field_offset); 8083 field_address = cond_offset_target (field_address, field_offset); 8084 field_type = ada_aligned_type (field_type); 8085 } 8086 8087 field_valaddr = cond_offset_host (field_valaddr, 8088 off / TARGET_CHAR_BIT); 8089 field_address = cond_offset_target (field_address, 8090 off / TARGET_CHAR_BIT); 8091 8092 /* Get the fixed type of the field. Note that, in this case, 8093 we do not want to get the real type out of the tag: if 8094 the current field is the parent part of a tagged record, 8095 we will get the tag of the object. Clearly wrong: the real 8096 type of the parent is not the real type of the child. We 8097 would end up in an infinite loop. */ 8098 field_type = ada_get_base_type (field_type); 8099 field_type = ada_to_fixed_type (field_type, field_valaddr, 8100 field_address, dval, 0); 8101 /* If the field size is already larger than the maximum 8102 object size, then the record itself will necessarily 8103 be larger than the maximum object size. We need to make 8104 this check now, because the size might be so ridiculously 8105 large (due to an uninitialized variable in the inferior) 8106 that it would cause an overflow when adding it to the 8107 record size. */ 8108 ada_ensure_varsize_limit (field_type); 8109 8110 TYPE_FIELD_TYPE (rtype, f) = field_type; 8111 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f); 8112 /* The multiplication can potentially overflow. But because 8113 the field length has been size-checked just above, and 8114 assuming that the maximum size is a reasonable value, 8115 an overflow should not happen in practice. So rather than 8116 adding overflow recovery code to this already complex code, 8117 we just assume that it's not going to happen. */ 8118 fld_bit_len = 8119 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT; 8120 } 8121 else 8122 { 8123 /* Note: If this field's type is a typedef, it is important 8124 to preserve the typedef layer. 8125 8126 Otherwise, we might be transforming a typedef to a fat 8127 pointer (encoding a pointer to an unconstrained array), 8128 into a basic fat pointer (encoding an unconstrained 8129 array). As both types are implemented using the same 8130 structure, the typedef is the only clue which allows us 8131 to distinguish between the two options. Stripping it 8132 would prevent us from printing this field appropriately. */ 8133 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f); 8134 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f); 8135 if (TYPE_FIELD_BITSIZE (type, f) > 0) 8136 fld_bit_len = 8137 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f); 8138 else 8139 { 8140 struct type *field_type = TYPE_FIELD_TYPE (type, f); 8141 8142 /* We need to be careful of typedefs when computing 8143 the length of our field. If this is a typedef, 8144 get the length of the target type, not the length 8145 of the typedef. */ 8146 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF) 8147 field_type = ada_typedef_target_type (field_type); 8148 8149 fld_bit_len = 8150 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT; 8151 } 8152 } 8153 if (off + fld_bit_len > bit_len) 8154 bit_len = off + fld_bit_len; 8155 off += fld_bit_len; 8156 TYPE_LENGTH (rtype) = 8157 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT; 8158 } 8159 8160 /* We handle the variant part, if any, at the end because of certain 8161 odd cases in which it is re-ordered so as NOT to be the last field of 8162 the record. This can happen in the presence of representation 8163 clauses. */ 8164 if (variant_field >= 0) 8165 { 8166 struct type *branch_type; 8167 8168 off = TYPE_FIELD_BITPOS (rtype, variant_field); 8169 8170 if (dval0 == NULL) 8171 { 8172 /* Using plain value_from_contents_and_address here causes 8173 problems because we will end up trying to resolve a type 8174 that is currently being constructed. */ 8175 dval = value_from_contents_and_address_unresolved (rtype, valaddr, 8176 address); 8177 rtype = value_type (dval); 8178 } 8179 else 8180 dval = dval0; 8181 8182 branch_type = 8183 to_fixed_variant_branch_type 8184 (TYPE_FIELD_TYPE (type, variant_field), 8185 cond_offset_host (valaddr, off / TARGET_CHAR_BIT), 8186 cond_offset_target (address, off / TARGET_CHAR_BIT), dval); 8187 if (branch_type == NULL) 8188 { 8189 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1) 8190 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f]; 8191 TYPE_NFIELDS (rtype) -= 1; 8192 } 8193 else 8194 { 8195 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type; 8196 TYPE_FIELD_NAME (rtype, variant_field) = "S"; 8197 fld_bit_len = 8198 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) * 8199 TARGET_CHAR_BIT; 8200 if (off + fld_bit_len > bit_len) 8201 bit_len = off + fld_bit_len; 8202 TYPE_LENGTH (rtype) = 8203 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT; 8204 } 8205 } 8206 8207 /* According to exp_dbug.ads, the size of TYPE for variable-size records 8208 should contain the alignment of that record, which should be a strictly 8209 positive value. If null or negative, then something is wrong, most 8210 probably in the debug info. In that case, we don't round up the size 8211 of the resulting type. If this record is not part of another structure, 8212 the current RTYPE length might be good enough for our purposes. */ 8213 if (TYPE_LENGTH (type) <= 0) 8214 { 8215 if (TYPE_NAME (rtype)) 8216 warning (_("Invalid type size for `%s' detected: %d."), 8217 TYPE_NAME (rtype), TYPE_LENGTH (type)); 8218 else 8219 warning (_("Invalid type size for <unnamed> detected: %d."), 8220 TYPE_LENGTH (type)); 8221 } 8222 else 8223 { 8224 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype), 8225 TYPE_LENGTH (type)); 8226 } 8227 8228 value_free_to_mark (mark); 8229 if (TYPE_LENGTH (rtype) > varsize_limit) 8230 error (_("record type with dynamic size is larger than varsize-limit")); 8231 return rtype; 8232} 8233 8234/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS 8235 of 1. */ 8236 8237static struct type * 8238template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr, 8239 CORE_ADDR address, struct value *dval0) 8240{ 8241 return ada_template_to_fixed_record_type_1 (type, valaddr, 8242 address, dval0, 1); 8243} 8244 8245/* An ordinary record type in which ___XVL-convention fields and 8246 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with 8247 static approximations, containing all possible fields. Uses 8248 no runtime values. Useless for use in values, but that's OK, 8249 since the results are used only for type determinations. Works on both 8250 structs and unions. Representation note: to save space, we memorize 8251 the result of this function in the TYPE_TARGET_TYPE of the 8252 template type. */ 8253 8254static struct type * 8255template_to_static_fixed_type (struct type *type0) 8256{ 8257 struct type *type; 8258 int nfields; 8259 int f; 8260 8261 /* No need no do anything if the input type is already fixed. */ 8262 if (TYPE_FIXED_INSTANCE (type0)) 8263 return type0; 8264 8265 /* Likewise if we already have computed the static approximation. */ 8266 if (TYPE_TARGET_TYPE (type0) != NULL) 8267 return TYPE_TARGET_TYPE (type0); 8268 8269 /* Don't clone TYPE0 until we are sure we are going to need a copy. */ 8270 type = type0; 8271 nfields = TYPE_NFIELDS (type0); 8272 8273 /* Whether or not we cloned TYPE0, cache the result so that we don't do 8274 recompute all over next time. */ 8275 TYPE_TARGET_TYPE (type0) = type; 8276 8277 for (f = 0; f < nfields; f += 1) 8278 { 8279 struct type *field_type = TYPE_FIELD_TYPE (type0, f); 8280 struct type *new_type; 8281 8282 if (is_dynamic_field (type0, f)) 8283 { 8284 field_type = ada_check_typedef (field_type); 8285 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type)); 8286 } 8287 else 8288 new_type = static_unwrap_type (field_type); 8289 8290 if (new_type != field_type) 8291 { 8292 /* Clone TYPE0 only the first time we get a new field type. */ 8293 if (type == type0) 8294 { 8295 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0); 8296 TYPE_CODE (type) = TYPE_CODE (type0); 8297 INIT_CPLUS_SPECIFIC (type); 8298 TYPE_NFIELDS (type) = nfields; 8299 TYPE_FIELDS (type) = (struct field *) 8300 TYPE_ALLOC (type, nfields * sizeof (struct field)); 8301 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0), 8302 sizeof (struct field) * nfields); 8303 TYPE_NAME (type) = ada_type_name (type0); 8304 TYPE_TAG_NAME (type) = NULL; 8305 TYPE_FIXED_INSTANCE (type) = 1; 8306 TYPE_LENGTH (type) = 0; 8307 } 8308 TYPE_FIELD_TYPE (type, f) = new_type; 8309 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f); 8310 } 8311 } 8312 8313 return type; 8314} 8315 8316/* Given an object of type TYPE whose contents are at VALADDR and 8317 whose address in memory is ADDRESS, returns a revision of TYPE, 8318 which should be a non-dynamic-sized record, in which the variant 8319 part, if any, is replaced with the appropriate branch. Looks 8320 for discriminant values in DVAL0, which can be NULL if the record 8321 contains the necessary discriminant values. */ 8322 8323static struct type * 8324to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr, 8325 CORE_ADDR address, struct value *dval0) 8326{ 8327 struct value *mark = value_mark (); 8328 struct value *dval; 8329 struct type *rtype; 8330 struct type *branch_type; 8331 int nfields = TYPE_NFIELDS (type); 8332 int variant_field = variant_field_index (type); 8333 8334 if (variant_field == -1) 8335 return type; 8336 8337 if (dval0 == NULL) 8338 { 8339 dval = value_from_contents_and_address (type, valaddr, address); 8340 type = value_type (dval); 8341 } 8342 else 8343 dval = dval0; 8344 8345 rtype = alloc_type_copy (type); 8346 TYPE_CODE (rtype) = TYPE_CODE_STRUCT; 8347 INIT_CPLUS_SPECIFIC (rtype); 8348 TYPE_NFIELDS (rtype) = nfields; 8349 TYPE_FIELDS (rtype) = 8350 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field)); 8351 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type), 8352 sizeof (struct field) * nfields); 8353 TYPE_NAME (rtype) = ada_type_name (type); 8354 TYPE_TAG_NAME (rtype) = NULL; 8355 TYPE_FIXED_INSTANCE (rtype) = 1; 8356 TYPE_LENGTH (rtype) = TYPE_LENGTH (type); 8357 8358 branch_type = to_fixed_variant_branch_type 8359 (TYPE_FIELD_TYPE (type, variant_field), 8360 cond_offset_host (valaddr, 8361 TYPE_FIELD_BITPOS (type, variant_field) 8362 / TARGET_CHAR_BIT), 8363 cond_offset_target (address, 8364 TYPE_FIELD_BITPOS (type, variant_field) 8365 / TARGET_CHAR_BIT), dval); 8366 if (branch_type == NULL) 8367 { 8368 int f; 8369 8370 for (f = variant_field + 1; f < nfields; f += 1) 8371 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f]; 8372 TYPE_NFIELDS (rtype) -= 1; 8373 } 8374 else 8375 { 8376 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type; 8377 TYPE_FIELD_NAME (rtype, variant_field) = "S"; 8378 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0; 8379 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type); 8380 } 8381 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field)); 8382 8383 value_free_to_mark (mark); 8384 return rtype; 8385} 8386 8387/* An ordinary record type (with fixed-length fields) that describes 8388 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at 8389 beginning of this section]. Any necessary discriminants' values 8390 should be in DVAL, a record value; it may be NULL if the object 8391 at ADDR itself contains any necessary discriminant values. 8392 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant 8393 values from the record are needed. Except in the case that DVAL, 8394 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless 8395 unchecked) is replaced by a particular branch of the variant. 8396 8397 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0 8398 is questionable and may be removed. It can arise during the 8399 processing of an unconstrained-array-of-record type where all the 8400 variant branches have exactly the same size. This is because in 8401 such cases, the compiler does not bother to use the XVS convention 8402 when encoding the record. I am currently dubious of this 8403 shortcut and suspect the compiler should be altered. FIXME. */ 8404 8405static struct type * 8406to_fixed_record_type (struct type *type0, const gdb_byte *valaddr, 8407 CORE_ADDR address, struct value *dval) 8408{ 8409 struct type *templ_type; 8410 8411 if (TYPE_FIXED_INSTANCE (type0)) 8412 return type0; 8413 8414 templ_type = dynamic_template_type (type0); 8415 8416 if (templ_type != NULL) 8417 return template_to_fixed_record_type (templ_type, valaddr, address, dval); 8418 else if (variant_field_index (type0) >= 0) 8419 { 8420 if (dval == NULL && valaddr == NULL && address == 0) 8421 return type0; 8422 return to_record_with_fixed_variant_part (type0, valaddr, address, 8423 dval); 8424 } 8425 else 8426 { 8427 TYPE_FIXED_INSTANCE (type0) = 1; 8428 return type0; 8429 } 8430 8431} 8432 8433/* An ordinary record type (with fixed-length fields) that describes 8434 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a 8435 union type. Any necessary discriminants' values should be in DVAL, 8436 a record value. That is, this routine selects the appropriate 8437 branch of the union at ADDR according to the discriminant value 8438 indicated in the union's type name. Returns VAR_TYPE0 itself if 8439 it represents a variant subject to a pragma Unchecked_Union. */ 8440 8441static struct type * 8442to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr, 8443 CORE_ADDR address, struct value *dval) 8444{ 8445 int which; 8446 struct type *templ_type; 8447 struct type *var_type; 8448 8449 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR) 8450 var_type = TYPE_TARGET_TYPE (var_type0); 8451 else 8452 var_type = var_type0; 8453 8454 templ_type = ada_find_parallel_type (var_type, "___XVU"); 8455 8456 if (templ_type != NULL) 8457 var_type = templ_type; 8458 8459 if (is_unchecked_variant (var_type, value_type (dval))) 8460 return var_type0; 8461 which = 8462 ada_which_variant_applies (var_type, 8463 value_type (dval), value_contents (dval)); 8464 8465 if (which < 0) 8466 return empty_record (var_type); 8467 else if (is_dynamic_field (var_type, which)) 8468 return to_fixed_record_type 8469 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)), 8470 valaddr, address, dval); 8471 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0) 8472 return 8473 to_fixed_record_type 8474 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval); 8475 else 8476 return TYPE_FIELD_TYPE (var_type, which); 8477} 8478 8479/* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if 8480 ENCODING_TYPE, a type following the GNAT conventions for discrete 8481 type encodings, only carries redundant information. */ 8482 8483static int 8484ada_is_redundant_range_encoding (struct type *range_type, 8485 struct type *encoding_type) 8486{ 8487 struct type *fixed_range_type; 8488 char *bounds_str; 8489 int n; 8490 LONGEST lo, hi; 8491 8492 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE); 8493 8494 if (TYPE_CODE (get_base_type (range_type)) 8495 != TYPE_CODE (get_base_type (encoding_type))) 8496 { 8497 /* The compiler probably used a simple base type to describe 8498 the range type instead of the range's actual base type, 8499 expecting us to get the real base type from the encoding 8500 anyway. In this situation, the encoding cannot be ignored 8501 as redundant. */ 8502 return 0; 8503 } 8504 8505 if (is_dynamic_type (range_type)) 8506 return 0; 8507 8508 if (TYPE_NAME (encoding_type) == NULL) 8509 return 0; 8510 8511 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_"); 8512 if (bounds_str == NULL) 8513 return 0; 8514 8515 n = 8; /* Skip "___XDLU_". */ 8516 if (!ada_scan_number (bounds_str, n, &lo, &n)) 8517 return 0; 8518 if (TYPE_LOW_BOUND (range_type) != lo) 8519 return 0; 8520 8521 n += 2; /* Skip the "__" separator between the two bounds. */ 8522 if (!ada_scan_number (bounds_str, n, &hi, &n)) 8523 return 0; 8524 if (TYPE_HIGH_BOUND (range_type) != hi) 8525 return 0; 8526 8527 return 1; 8528} 8529 8530/* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE, 8531 a type following the GNAT encoding for describing array type 8532 indices, only carries redundant information. */ 8533 8534static int 8535ada_is_redundant_index_type_desc (struct type *array_type, 8536 struct type *desc_type) 8537{ 8538 struct type *this_layer = check_typedef (array_type); 8539 int i; 8540 8541 for (i = 0; i < TYPE_NFIELDS (desc_type); i++) 8542 { 8543 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer), 8544 TYPE_FIELD_TYPE (desc_type, i))) 8545 return 0; 8546 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer)); 8547 } 8548 8549 return 1; 8550} 8551 8552/* Assuming that TYPE0 is an array type describing the type of a value 8553 at ADDR, and that DVAL describes a record containing any 8554 discriminants used in TYPE0, returns a type for the value that 8555 contains no dynamic components (that is, no components whose sizes 8556 are determined by run-time quantities). Unless IGNORE_TOO_BIG is 8557 true, gives an error message if the resulting type's size is over 8558 varsize_limit. */ 8559 8560static struct type * 8561to_fixed_array_type (struct type *type0, struct value *dval, 8562 int ignore_too_big) 8563{ 8564 struct type *index_type_desc; 8565 struct type *result; 8566 int constrained_packed_array_p; 8567 static const char *xa_suffix = "___XA"; 8568 8569 type0 = ada_check_typedef (type0); 8570 if (TYPE_FIXED_INSTANCE (type0)) 8571 return type0; 8572 8573 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0); 8574 if (constrained_packed_array_p) 8575 type0 = decode_constrained_packed_array_type (type0); 8576 8577 index_type_desc = ada_find_parallel_type (type0, xa_suffix); 8578 8579 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an 8580 encoding suffixed with 'P' may still be generated. If so, 8581 it should be used to find the XA type. */ 8582 8583 if (index_type_desc == NULL) 8584 { 8585 const char *type_name = ada_type_name (type0); 8586 8587 if (type_name != NULL) 8588 { 8589 const int len = strlen (type_name); 8590 char *name = (char *) alloca (len + strlen (xa_suffix)); 8591 8592 if (type_name[len - 1] == 'P') 8593 { 8594 strcpy (name, type_name); 8595 strcpy (name + len - 1, xa_suffix); 8596 index_type_desc = ada_find_parallel_type_with_name (type0, name); 8597 } 8598 } 8599 } 8600 8601 ada_fixup_array_indexes_type (index_type_desc); 8602 if (index_type_desc != NULL 8603 && ada_is_redundant_index_type_desc (type0, index_type_desc)) 8604 { 8605 /* Ignore this ___XA parallel type, as it does not bring any 8606 useful information. This allows us to avoid creating fixed 8607 versions of the array's index types, which would be identical 8608 to the original ones. This, in turn, can also help avoid 8609 the creation of fixed versions of the array itself. */ 8610 index_type_desc = NULL; 8611 } 8612 8613 if (index_type_desc == NULL) 8614 { 8615 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0)); 8616 8617 /* NOTE: elt_type---the fixed version of elt_type0---should never 8618 depend on the contents of the array in properly constructed 8619 debugging data. */ 8620 /* Create a fixed version of the array element type. 8621 We're not providing the address of an element here, 8622 and thus the actual object value cannot be inspected to do 8623 the conversion. This should not be a problem, since arrays of 8624 unconstrained objects are not allowed. In particular, all 8625 the elements of an array of a tagged type should all be of 8626 the same type specified in the debugging info. No need to 8627 consult the object tag. */ 8628 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1); 8629 8630 /* Make sure we always create a new array type when dealing with 8631 packed array types, since we're going to fix-up the array 8632 type length and element bitsize a little further down. */ 8633 if (elt_type0 == elt_type && !constrained_packed_array_p) 8634 result = type0; 8635 else 8636 result = create_array_type (alloc_type_copy (type0), 8637 elt_type, TYPE_INDEX_TYPE (type0)); 8638 } 8639 else 8640 { 8641 int i; 8642 struct type *elt_type0; 8643 8644 elt_type0 = type0; 8645 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1) 8646 elt_type0 = TYPE_TARGET_TYPE (elt_type0); 8647 8648 /* NOTE: result---the fixed version of elt_type0---should never 8649 depend on the contents of the array in properly constructed 8650 debugging data. */ 8651 /* Create a fixed version of the array element type. 8652 We're not providing the address of an element here, 8653 and thus the actual object value cannot be inspected to do 8654 the conversion. This should not be a problem, since arrays of 8655 unconstrained objects are not allowed. In particular, all 8656 the elements of an array of a tagged type should all be of 8657 the same type specified in the debugging info. No need to 8658 consult the object tag. */ 8659 result = 8660 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1); 8661 8662 elt_type0 = type0; 8663 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1) 8664 { 8665 struct type *range_type = 8666 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval); 8667 8668 result = create_array_type (alloc_type_copy (elt_type0), 8669 result, range_type); 8670 elt_type0 = TYPE_TARGET_TYPE (elt_type0); 8671 } 8672 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit) 8673 error (_("array type with dynamic size is larger than varsize-limit")); 8674 } 8675 8676 /* We want to preserve the type name. This can be useful when 8677 trying to get the type name of a value that has already been 8678 printed (for instance, if the user did "print VAR; whatis $". */ 8679 TYPE_NAME (result) = TYPE_NAME (type0); 8680 8681 if (constrained_packed_array_p) 8682 { 8683 /* So far, the resulting type has been created as if the original 8684 type was a regular (non-packed) array type. As a result, the 8685 bitsize of the array elements needs to be set again, and the array 8686 length needs to be recomputed based on that bitsize. */ 8687 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result)); 8688 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0); 8689 8690 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0); 8691 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT; 8692 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize) 8693 TYPE_LENGTH (result)++; 8694 } 8695 8696 TYPE_FIXED_INSTANCE (result) = 1; 8697 return result; 8698} 8699 8700 8701/* A standard type (containing no dynamically sized components) 8702 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS) 8703 DVAL describes a record containing any discriminants used in TYPE0, 8704 and may be NULL if there are none, or if the object of type TYPE at 8705 ADDRESS or in VALADDR contains these discriminants. 8706 8707 If CHECK_TAG is not null, in the case of tagged types, this function 8708 attempts to locate the object's tag and use it to compute the actual 8709 type. However, when ADDRESS is null, we cannot use it to determine the 8710 location of the tag, and therefore compute the tagged type's actual type. 8711 So we return the tagged type without consulting the tag. */ 8712 8713static struct type * 8714ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr, 8715 CORE_ADDR address, struct value *dval, int check_tag) 8716{ 8717 type = ada_check_typedef (type); 8718 switch (TYPE_CODE (type)) 8719 { 8720 default: 8721 return type; 8722 case TYPE_CODE_STRUCT: 8723 { 8724 struct type *static_type = to_static_fixed_type (type); 8725 struct type *fixed_record_type = 8726 to_fixed_record_type (type, valaddr, address, NULL); 8727 8728 /* If STATIC_TYPE is a tagged type and we know the object's address, 8729 then we can determine its tag, and compute the object's actual 8730 type from there. Note that we have to use the fixed record 8731 type (the parent part of the record may have dynamic fields 8732 and the way the location of _tag is expressed may depend on 8733 them). */ 8734 8735 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0)) 8736 { 8737 struct value *tag = 8738 value_tag_from_contents_and_address 8739 (fixed_record_type, 8740 valaddr, 8741 address); 8742 struct type *real_type = type_from_tag (tag); 8743 struct value *obj = 8744 value_from_contents_and_address (fixed_record_type, 8745 valaddr, 8746 address); 8747 fixed_record_type = value_type (obj); 8748 if (real_type != NULL) 8749 return to_fixed_record_type 8750 (real_type, NULL, 8751 value_address (ada_tag_value_at_base_address (obj)), NULL); 8752 } 8753 8754 /* Check to see if there is a parallel ___XVZ variable. 8755 If there is, then it provides the actual size of our type. */ 8756 else if (ada_type_name (fixed_record_type) != NULL) 8757 { 8758 const char *name = ada_type_name (fixed_record_type); 8759 char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */); 8760 int xvz_found = 0; 8761 LONGEST size; 8762 8763 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name); 8764 size = get_int_var_value (xvz_name, &xvz_found); 8765 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size) 8766 { 8767 fixed_record_type = copy_type (fixed_record_type); 8768 TYPE_LENGTH (fixed_record_type) = size; 8769 8770 /* The FIXED_RECORD_TYPE may have be a stub. We have 8771 observed this when the debugging info is STABS, and 8772 apparently it is something that is hard to fix. 8773 8774 In practice, we don't need the actual type definition 8775 at all, because the presence of the XVZ variable allows us 8776 to assume that there must be a XVS type as well, which we 8777 should be able to use later, when we need the actual type 8778 definition. 8779 8780 In the meantime, pretend that the "fixed" type we are 8781 returning is NOT a stub, because this can cause trouble 8782 when using this type to create new types targeting it. 8783 Indeed, the associated creation routines often check 8784 whether the target type is a stub and will try to replace 8785 it, thus using a type with the wrong size. This, in turn, 8786 might cause the new type to have the wrong size too. 8787 Consider the case of an array, for instance, where the size 8788 of the array is computed from the number of elements in 8789 our array multiplied by the size of its element. */ 8790 TYPE_STUB (fixed_record_type) = 0; 8791 } 8792 } 8793 return fixed_record_type; 8794 } 8795 case TYPE_CODE_ARRAY: 8796 return to_fixed_array_type (type, dval, 1); 8797 case TYPE_CODE_UNION: 8798 if (dval == NULL) 8799 return type; 8800 else 8801 return to_fixed_variant_branch_type (type, valaddr, address, dval); 8802 } 8803} 8804 8805/* The same as ada_to_fixed_type_1, except that it preserves the type 8806 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed. 8807 8808 The typedef layer needs be preserved in order to differentiate between 8809 arrays and array pointers when both types are implemented using the same 8810 fat pointer. In the array pointer case, the pointer is encoded as 8811 a typedef of the pointer type. For instance, considering: 8812 8813 type String_Access is access String; 8814 S1 : String_Access := null; 8815 8816 To the debugger, S1 is defined as a typedef of type String. But 8817 to the user, it is a pointer. So if the user tries to print S1, 8818 we should not dereference the array, but print the array address 8819 instead. 8820 8821 If we didn't preserve the typedef layer, we would lose the fact that 8822 the type is to be presented as a pointer (needs de-reference before 8823 being printed). And we would also use the source-level type name. */ 8824 8825struct type * 8826ada_to_fixed_type (struct type *type, const gdb_byte *valaddr, 8827 CORE_ADDR address, struct value *dval, int check_tag) 8828 8829{ 8830 struct type *fixed_type = 8831 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag); 8832 8833 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE, 8834 then preserve the typedef layer. 8835 8836 Implementation note: We can only check the main-type portion of 8837 the TYPE and FIXED_TYPE, because eliminating the typedef layer 8838 from TYPE now returns a type that has the same instance flags 8839 as TYPE. For instance, if TYPE is a "typedef const", and its 8840 target type is a "struct", then the typedef elimination will return 8841 a "const" version of the target type. See check_typedef for more 8842 details about how the typedef layer elimination is done. 8843 8844 brobecker/2010-11-19: It seems to me that the only case where it is 8845 useful to preserve the typedef layer is when dealing with fat pointers. 8846 Perhaps, we could add a check for that and preserve the typedef layer 8847 only in that situation. But this seems unecessary so far, probably 8848 because we call check_typedef/ada_check_typedef pretty much everywhere. 8849 */ 8850 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF 8851 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type)) 8852 == TYPE_MAIN_TYPE (fixed_type))) 8853 return type; 8854 8855 return fixed_type; 8856} 8857 8858/* A standard (static-sized) type corresponding as well as possible to 8859 TYPE0, but based on no runtime data. */ 8860 8861static struct type * 8862to_static_fixed_type (struct type *type0) 8863{ 8864 struct type *type; 8865 8866 if (type0 == NULL) 8867 return NULL; 8868 8869 if (TYPE_FIXED_INSTANCE (type0)) 8870 return type0; 8871 8872 type0 = ada_check_typedef (type0); 8873 8874 switch (TYPE_CODE (type0)) 8875 { 8876 default: 8877 return type0; 8878 case TYPE_CODE_STRUCT: 8879 type = dynamic_template_type (type0); 8880 if (type != NULL) 8881 return template_to_static_fixed_type (type); 8882 else 8883 return template_to_static_fixed_type (type0); 8884 case TYPE_CODE_UNION: 8885 type = ada_find_parallel_type (type0, "___XVU"); 8886 if (type != NULL) 8887 return template_to_static_fixed_type (type); 8888 else 8889 return template_to_static_fixed_type (type0); 8890 } 8891} 8892 8893/* A static approximation of TYPE with all type wrappers removed. */ 8894 8895static struct type * 8896static_unwrap_type (struct type *type) 8897{ 8898 if (ada_is_aligner_type (type)) 8899 { 8900 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0); 8901 if (ada_type_name (type1) == NULL) 8902 TYPE_NAME (type1) = ada_type_name (type); 8903 8904 return static_unwrap_type (type1); 8905 } 8906 else 8907 { 8908 struct type *raw_real_type = ada_get_base_type (type); 8909 8910 if (raw_real_type == type) 8911 return type; 8912 else 8913 return to_static_fixed_type (raw_real_type); 8914 } 8915} 8916 8917/* In some cases, incomplete and private types require 8918 cross-references that are not resolved as records (for example, 8919 type Foo; 8920 type FooP is access Foo; 8921 V: FooP; 8922 type Foo is array ...; 8923 ). In these cases, since there is no mechanism for producing 8924 cross-references to such types, we instead substitute for FooP a 8925 stub enumeration type that is nowhere resolved, and whose tag is 8926 the name of the actual type. Call these types "non-record stubs". */ 8927 8928/* A type equivalent to TYPE that is not a non-record stub, if one 8929 exists, otherwise TYPE. */ 8930 8931struct type * 8932ada_check_typedef (struct type *type) 8933{ 8934 if (type == NULL) 8935 return NULL; 8936 8937 /* If our type is a typedef type of a fat pointer, then we're done. 8938 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is 8939 what allows us to distinguish between fat pointers that represent 8940 array types, and fat pointers that represent array access types 8941 (in both cases, the compiler implements them as fat pointers). */ 8942 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF 8943 && is_thick_pntr (ada_typedef_target_type (type))) 8944 return type; 8945 8946 CHECK_TYPEDEF (type); 8947 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM 8948 || !TYPE_STUB (type) 8949 || TYPE_TAG_NAME (type) == NULL) 8950 return type; 8951 else 8952 { 8953 const char *name = TYPE_TAG_NAME (type); 8954 struct type *type1 = ada_find_any_type (name); 8955 8956 if (type1 == NULL) 8957 return type; 8958 8959 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with 8960 stubs pointing to arrays, as we don't create symbols for array 8961 types, only for the typedef-to-array types). If that's the case, 8962 strip the typedef layer. */ 8963 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF) 8964 type1 = ada_check_typedef (type1); 8965 8966 return type1; 8967 } 8968} 8969 8970/* A value representing the data at VALADDR/ADDRESS as described by 8971 type TYPE0, but with a standard (static-sized) type that correctly 8972 describes it. If VAL0 is not NULL and TYPE0 already is a standard 8973 type, then return VAL0 [this feature is simply to avoid redundant 8974 creation of struct values]. */ 8975 8976static struct value * 8977ada_to_fixed_value_create (struct type *type0, CORE_ADDR address, 8978 struct value *val0) 8979{ 8980 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1); 8981 8982 if (type == type0 && val0 != NULL) 8983 return val0; 8984 else 8985 return value_from_contents_and_address (type, 0, address); 8986} 8987 8988/* A value representing VAL, but with a standard (static-sized) type 8989 that correctly describes it. Does not necessarily create a new 8990 value. */ 8991 8992struct value * 8993ada_to_fixed_value (struct value *val) 8994{ 8995 val = unwrap_value (val); 8996 val = ada_to_fixed_value_create (value_type (val), 8997 value_address (val), 8998 val); 8999 return val; 9000} 9001 9002 9003/* Attributes */ 9004 9005/* Table mapping attribute numbers to names. 9006 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */ 9007 9008static const char *attribute_names[] = { 9009 "<?>", 9010 9011 "first", 9012 "last", 9013 "length", 9014 "image", 9015 "max", 9016 "min", 9017 "modulus", 9018 "pos", 9019 "size", 9020 "tag", 9021 "val", 9022 0 9023}; 9024 9025const char * 9026ada_attribute_name (enum exp_opcode n) 9027{ 9028 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL) 9029 return attribute_names[n - OP_ATR_FIRST + 1]; 9030 else 9031 return attribute_names[0]; 9032} 9033 9034/* Evaluate the 'POS attribute applied to ARG. */ 9035 9036static LONGEST 9037pos_atr (struct value *arg) 9038{ 9039 struct value *val = coerce_ref (arg); 9040 struct type *type = value_type (val); 9041 LONGEST result; 9042 9043 if (!discrete_type_p (type)) 9044 error (_("'POS only defined on discrete types")); 9045 9046 if (!discrete_position (type, value_as_long (val), &result)) 9047 error (_("enumeration value is invalid: can't find 'POS")); 9048 9049 return result; 9050} 9051 9052static struct value * 9053value_pos_atr (struct type *type, struct value *arg) 9054{ 9055 return value_from_longest (type, pos_atr (arg)); 9056} 9057 9058/* Evaluate the TYPE'VAL attribute applied to ARG. */ 9059 9060static struct value * 9061value_val_atr (struct type *type, struct value *arg) 9062{ 9063 if (!discrete_type_p (type)) 9064 error (_("'VAL only defined on discrete types")); 9065 if (!integer_type_p (value_type (arg))) 9066 error (_("'VAL requires integral argument")); 9067 9068 if (TYPE_CODE (type) == TYPE_CODE_ENUM) 9069 { 9070 long pos = value_as_long (arg); 9071 9072 if (pos < 0 || pos >= TYPE_NFIELDS (type)) 9073 error (_("argument to 'VAL out of range")); 9074 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos)); 9075 } 9076 else 9077 return value_from_longest (type, value_as_long (arg)); 9078} 9079 9080 9081 /* Evaluation */ 9082 9083/* True if TYPE appears to be an Ada character type. 9084 [At the moment, this is true only for Character and Wide_Character; 9085 It is a heuristic test that could stand improvement]. */ 9086 9087int 9088ada_is_character_type (struct type *type) 9089{ 9090 const char *name; 9091 9092 /* If the type code says it's a character, then assume it really is, 9093 and don't check any further. */ 9094 if (TYPE_CODE (type) == TYPE_CODE_CHAR) 9095 return 1; 9096 9097 /* Otherwise, assume it's a character type iff it is a discrete type 9098 with a known character type name. */ 9099 name = ada_type_name (type); 9100 return (name != NULL 9101 && (TYPE_CODE (type) == TYPE_CODE_INT 9102 || TYPE_CODE (type) == TYPE_CODE_RANGE) 9103 && (strcmp (name, "character") == 0 9104 || strcmp (name, "wide_character") == 0 9105 || strcmp (name, "wide_wide_character") == 0 9106 || strcmp (name, "unsigned char") == 0)); 9107} 9108 9109/* True if TYPE appears to be an Ada string type. */ 9110 9111int 9112ada_is_string_type (struct type *type) 9113{ 9114 type = ada_check_typedef (type); 9115 if (type != NULL 9116 && TYPE_CODE (type) != TYPE_CODE_PTR 9117 && (ada_is_simple_array_type (type) 9118 || ada_is_array_descriptor_type (type)) 9119 && ada_array_arity (type) == 1) 9120 { 9121 struct type *elttype = ada_array_element_type (type, 1); 9122 9123 return ada_is_character_type (elttype); 9124 } 9125 else 9126 return 0; 9127} 9128 9129/* The compiler sometimes provides a parallel XVS type for a given 9130 PAD type. Normally, it is safe to follow the PAD type directly, 9131 but older versions of the compiler have a bug that causes the offset 9132 of its "F" field to be wrong. Following that field in that case 9133 would lead to incorrect results, but this can be worked around 9134 by ignoring the PAD type and using the associated XVS type instead. 9135 9136 Set to True if the debugger should trust the contents of PAD types. 9137 Otherwise, ignore the PAD type if there is a parallel XVS type. */ 9138static int trust_pad_over_xvs = 1; 9139 9140/* True if TYPE is a struct type introduced by the compiler to force the 9141 alignment of a value. Such types have a single field with a 9142 distinctive name. */ 9143 9144int 9145ada_is_aligner_type (struct type *type) 9146{ 9147 type = ada_check_typedef (type); 9148 9149 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL) 9150 return 0; 9151 9152 return (TYPE_CODE (type) == TYPE_CODE_STRUCT 9153 && TYPE_NFIELDS (type) == 1 9154 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0); 9155} 9156 9157/* If there is an ___XVS-convention type parallel to SUBTYPE, return 9158 the parallel type. */ 9159 9160struct type * 9161ada_get_base_type (struct type *raw_type) 9162{ 9163 struct type *real_type_namer; 9164 struct type *raw_real_type; 9165 9166 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT) 9167 return raw_type; 9168 9169 if (ada_is_aligner_type (raw_type)) 9170 /* The encoding specifies that we should always use the aligner type. 9171 So, even if this aligner type has an associated XVS type, we should 9172 simply ignore it. 9173 9174 According to the compiler gurus, an XVS type parallel to an aligner 9175 type may exist because of a stabs limitation. In stabs, aligner 9176 types are empty because the field has a variable-sized type, and 9177 thus cannot actually be used as an aligner type. As a result, 9178 we need the associated parallel XVS type to decode the type. 9179 Since the policy in the compiler is to not change the internal 9180 representation based on the debugging info format, we sometimes 9181 end up having a redundant XVS type parallel to the aligner type. */ 9182 return raw_type; 9183 9184 real_type_namer = ada_find_parallel_type (raw_type, "___XVS"); 9185 if (real_type_namer == NULL 9186 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT 9187 || TYPE_NFIELDS (real_type_namer) != 1) 9188 return raw_type; 9189 9190 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF) 9191 { 9192 /* This is an older encoding form where the base type needs to be 9193 looked up by name. We prefer the newer enconding because it is 9194 more efficient. */ 9195 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0)); 9196 if (raw_real_type == NULL) 9197 return raw_type; 9198 else 9199 return raw_real_type; 9200 } 9201 9202 /* The field in our XVS type is a reference to the base type. */ 9203 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0)); 9204} 9205 9206/* The type of value designated by TYPE, with all aligners removed. */ 9207 9208struct type * 9209ada_aligned_type (struct type *type) 9210{ 9211 if (ada_is_aligner_type (type)) 9212 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0)); 9213 else 9214 return ada_get_base_type (type); 9215} 9216 9217 9218/* The address of the aligned value in an object at address VALADDR 9219 having type TYPE. Assumes ada_is_aligner_type (TYPE). */ 9220 9221const gdb_byte * 9222ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr) 9223{ 9224 if (ada_is_aligner_type (type)) 9225 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0), 9226 valaddr + 9227 TYPE_FIELD_BITPOS (type, 9228 0) / TARGET_CHAR_BIT); 9229 else 9230 return valaddr; 9231} 9232 9233 9234 9235/* The printed representation of an enumeration literal with encoded 9236 name NAME. The value is good to the next call of ada_enum_name. */ 9237const char * 9238ada_enum_name (const char *name) 9239{ 9240 static char *result; 9241 static size_t result_len = 0; 9242 char *tmp; 9243 9244 /* First, unqualify the enumeration name: 9245 1. Search for the last '.' character. If we find one, then skip 9246 all the preceding characters, the unqualified name starts 9247 right after that dot. 9248 2. Otherwise, we may be debugging on a target where the compiler 9249 translates dots into "__". Search forward for double underscores, 9250 but stop searching when we hit an overloading suffix, which is 9251 of the form "__" followed by digits. */ 9252 9253 tmp = strrchr (name, '.'); 9254 if (tmp != NULL) 9255 name = tmp + 1; 9256 else 9257 { 9258 while ((tmp = strstr (name, "__")) != NULL) 9259 { 9260 if (isdigit (tmp[2])) 9261 break; 9262 else 9263 name = tmp + 2; 9264 } 9265 } 9266 9267 if (name[0] == 'Q') 9268 { 9269 int v; 9270 9271 if (name[1] == 'U' || name[1] == 'W') 9272 { 9273 if (sscanf (name + 2, "%x", &v) != 1) 9274 return name; 9275 } 9276 else 9277 return name; 9278 9279 GROW_VECT (result, result_len, 16); 9280 if (isascii (v) && isprint (v)) 9281 xsnprintf (result, result_len, "'%c'", v); 9282 else if (name[1] == 'U') 9283 xsnprintf (result, result_len, "[\"%02x\"]", v); 9284 else 9285 xsnprintf (result, result_len, "[\"%04x\"]", v); 9286 9287 return result; 9288 } 9289 else 9290 { 9291 tmp = strstr (name, "__"); 9292 if (tmp == NULL) 9293 tmp = strstr (name, "$"); 9294 if (tmp != NULL) 9295 { 9296 GROW_VECT (result, result_len, tmp - name + 1); 9297 strncpy (result, name, tmp - name); 9298 result[tmp - name] = '\0'; 9299 return result; 9300 } 9301 9302 return name; 9303 } 9304} 9305 9306/* Evaluate the subexpression of EXP starting at *POS as for 9307 evaluate_type, updating *POS to point just past the evaluated 9308 expression. */ 9309 9310static struct value * 9311evaluate_subexp_type (struct expression *exp, int *pos) 9312{ 9313 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS); 9314} 9315 9316/* If VAL is wrapped in an aligner or subtype wrapper, return the 9317 value it wraps. */ 9318 9319static struct value * 9320unwrap_value (struct value *val) 9321{ 9322 struct type *type = ada_check_typedef (value_type (val)); 9323 9324 if (ada_is_aligner_type (type)) 9325 { 9326 struct value *v = ada_value_struct_elt (val, "F", 0); 9327 struct type *val_type = ada_check_typedef (value_type (v)); 9328 9329 if (ada_type_name (val_type) == NULL) 9330 TYPE_NAME (val_type) = ada_type_name (type); 9331 9332 return unwrap_value (v); 9333 } 9334 else 9335 { 9336 struct type *raw_real_type = 9337 ada_check_typedef (ada_get_base_type (type)); 9338 9339 /* If there is no parallel XVS or XVE type, then the value is 9340 already unwrapped. Return it without further modification. */ 9341 if ((type == raw_real_type) 9342 && ada_find_parallel_type (type, "___XVE") == NULL) 9343 return val; 9344 9345 return 9346 coerce_unspec_val_to_type 9347 (val, ada_to_fixed_type (raw_real_type, 0, 9348 value_address (val), 9349 NULL, 1)); 9350 } 9351} 9352 9353static struct value * 9354cast_to_fixed (struct type *type, struct value *arg) 9355{ 9356 LONGEST val; 9357 9358 if (type == value_type (arg)) 9359 return arg; 9360 else if (ada_is_fixed_point_type (value_type (arg))) 9361 val = ada_float_to_fixed (type, 9362 ada_fixed_to_float (value_type (arg), 9363 value_as_long (arg))); 9364 else 9365 { 9366 DOUBLEST argd = value_as_double (arg); 9367 9368 val = ada_float_to_fixed (type, argd); 9369 } 9370 9371 return value_from_longest (type, val); 9372} 9373 9374static struct value * 9375cast_from_fixed (struct type *type, struct value *arg) 9376{ 9377 DOUBLEST val = ada_fixed_to_float (value_type (arg), 9378 value_as_long (arg)); 9379 9380 return value_from_double (type, val); 9381} 9382 9383/* Given two array types T1 and T2, return nonzero iff both arrays 9384 contain the same number of elements. */ 9385 9386static int 9387ada_same_array_size_p (struct type *t1, struct type *t2) 9388{ 9389 LONGEST lo1, hi1, lo2, hi2; 9390 9391 /* Get the array bounds in order to verify that the size of 9392 the two arrays match. */ 9393 if (!get_array_bounds (t1, &lo1, &hi1) 9394 || !get_array_bounds (t2, &lo2, &hi2)) 9395 error (_("unable to determine array bounds")); 9396 9397 /* To make things easier for size comparison, normalize a bit 9398 the case of empty arrays by making sure that the difference 9399 between upper bound and lower bound is always -1. */ 9400 if (lo1 > hi1) 9401 hi1 = lo1 - 1; 9402 if (lo2 > hi2) 9403 hi2 = lo2 - 1; 9404 9405 return (hi1 - lo1 == hi2 - lo2); 9406} 9407 9408/* Assuming that VAL is an array of integrals, and TYPE represents 9409 an array with the same number of elements, but with wider integral 9410 elements, return an array "casted" to TYPE. In practice, this 9411 means that the returned array is built by casting each element 9412 of the original array into TYPE's (wider) element type. */ 9413 9414static struct value * 9415ada_promote_array_of_integrals (struct type *type, struct value *val) 9416{ 9417 struct type *elt_type = TYPE_TARGET_TYPE (type); 9418 LONGEST lo, hi; 9419 struct value *res; 9420 LONGEST i; 9421 9422 /* Verify that both val and type are arrays of scalars, and 9423 that the size of val's elements is smaller than the size 9424 of type's element. */ 9425 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY); 9426 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type))); 9427 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY); 9428 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val)))); 9429 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type)) 9430 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val)))); 9431 9432 if (!get_array_bounds (type, &lo, &hi)) 9433 error (_("unable to determine array bounds")); 9434 9435 res = allocate_value (type); 9436 9437 /* Promote each array element. */ 9438 for (i = 0; i < hi - lo + 1; i++) 9439 { 9440 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i)); 9441 9442 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)), 9443 value_contents_all (elt), TYPE_LENGTH (elt_type)); 9444 } 9445 9446 return res; 9447} 9448 9449/* Coerce VAL as necessary for assignment to an lval of type TYPE, and 9450 return the converted value. */ 9451 9452static struct value * 9453coerce_for_assign (struct type *type, struct value *val) 9454{ 9455 struct type *type2 = value_type (val); 9456 9457 if (type == type2) 9458 return val; 9459 9460 type2 = ada_check_typedef (type2); 9461 type = ada_check_typedef (type); 9462 9463 if (TYPE_CODE (type2) == TYPE_CODE_PTR 9464 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 9465 { 9466 val = ada_value_ind (val); 9467 type2 = value_type (val); 9468 } 9469 9470 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY 9471 && TYPE_CODE (type) == TYPE_CODE_ARRAY) 9472 { 9473 if (!ada_same_array_size_p (type, type2)) 9474 error (_("cannot assign arrays of different length")); 9475 9476 if (is_integral_type (TYPE_TARGET_TYPE (type)) 9477 && is_integral_type (TYPE_TARGET_TYPE (type2)) 9478 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2)) 9479 < TYPE_LENGTH (TYPE_TARGET_TYPE (type))) 9480 { 9481 /* Allow implicit promotion of the array elements to 9482 a wider type. */ 9483 return ada_promote_array_of_integrals (type, val); 9484 } 9485 9486 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2)) 9487 != TYPE_LENGTH (TYPE_TARGET_TYPE (type))) 9488 error (_("Incompatible types in assignment")); 9489 deprecated_set_value_type (val, type); 9490 } 9491 return val; 9492} 9493 9494static struct value * 9495ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op) 9496{ 9497 struct value *val; 9498 struct type *type1, *type2; 9499 LONGEST v, v1, v2; 9500 9501 arg1 = coerce_ref (arg1); 9502 arg2 = coerce_ref (arg2); 9503 type1 = get_base_type (ada_check_typedef (value_type (arg1))); 9504 type2 = get_base_type (ada_check_typedef (value_type (arg2))); 9505 9506 if (TYPE_CODE (type1) != TYPE_CODE_INT 9507 || TYPE_CODE (type2) != TYPE_CODE_INT) 9508 return value_binop (arg1, arg2, op); 9509 9510 switch (op) 9511 { 9512 case BINOP_MOD: 9513 case BINOP_DIV: 9514 case BINOP_REM: 9515 break; 9516 default: 9517 return value_binop (arg1, arg2, op); 9518 } 9519 9520 v2 = value_as_long (arg2); 9521 if (v2 == 0) 9522 error (_("second operand of %s must not be zero."), op_string (op)); 9523 9524 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD) 9525 return value_binop (arg1, arg2, op); 9526 9527 v1 = value_as_long (arg1); 9528 switch (op) 9529 { 9530 case BINOP_DIV: 9531 v = v1 / v2; 9532 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0) 9533 v += v > 0 ? -1 : 1; 9534 break; 9535 case BINOP_REM: 9536 v = v1 % v2; 9537 if (v * v1 < 0) 9538 v -= v2; 9539 break; 9540 default: 9541 /* Should not reach this point. */ 9542 v = 0; 9543 } 9544 9545 val = allocate_value (type1); 9546 store_unsigned_integer (value_contents_raw (val), 9547 TYPE_LENGTH (value_type (val)), 9548 gdbarch_byte_order (get_type_arch (type1)), v); 9549 return val; 9550} 9551 9552static int 9553ada_value_equal (struct value *arg1, struct value *arg2) 9554{ 9555 if (ada_is_direct_array_type (value_type (arg1)) 9556 || ada_is_direct_array_type (value_type (arg2))) 9557 { 9558 /* Automatically dereference any array reference before 9559 we attempt to perform the comparison. */ 9560 arg1 = ada_coerce_ref (arg1); 9561 arg2 = ada_coerce_ref (arg2); 9562 9563 arg1 = ada_coerce_to_simple_array (arg1); 9564 arg2 = ada_coerce_to_simple_array (arg2); 9565 if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY 9566 || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY) 9567 error (_("Attempt to compare array with non-array")); 9568 /* FIXME: The following works only for types whose 9569 representations use all bits (no padding or undefined bits) 9570 and do not have user-defined equality. */ 9571 return 9572 TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2)) 9573 && memcmp (value_contents (arg1), value_contents (arg2), 9574 TYPE_LENGTH (value_type (arg1))) == 0; 9575 } 9576 return value_equal (arg1, arg2); 9577} 9578 9579/* Total number of component associations in the aggregate starting at 9580 index PC in EXP. Assumes that index PC is the start of an 9581 OP_AGGREGATE. */ 9582 9583static int 9584num_component_specs (struct expression *exp, int pc) 9585{ 9586 int n, m, i; 9587 9588 m = exp->elts[pc + 1].longconst; 9589 pc += 3; 9590 n = 0; 9591 for (i = 0; i < m; i += 1) 9592 { 9593 switch (exp->elts[pc].opcode) 9594 { 9595 default: 9596 n += 1; 9597 break; 9598 case OP_CHOICES: 9599 n += exp->elts[pc + 1].longconst; 9600 break; 9601 } 9602 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP); 9603 } 9604 return n; 9605} 9606 9607/* Assign the result of evaluating EXP starting at *POS to the INDEXth 9608 component of LHS (a simple array or a record), updating *POS past 9609 the expression, assuming that LHS is contained in CONTAINER. Does 9610 not modify the inferior's memory, nor does it modify LHS (unless 9611 LHS == CONTAINER). */ 9612 9613static void 9614assign_component (struct value *container, struct value *lhs, LONGEST index, 9615 struct expression *exp, int *pos) 9616{ 9617 struct value *mark = value_mark (); 9618 struct value *elt; 9619 9620 if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY) 9621 { 9622 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int; 9623 struct value *index_val = value_from_longest (index_type, index); 9624 9625 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val)); 9626 } 9627 else 9628 { 9629 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs)); 9630 elt = ada_to_fixed_value (elt); 9631 } 9632 9633 if (exp->elts[*pos].opcode == OP_AGGREGATE) 9634 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL); 9635 else 9636 value_assign_to_component (container, elt, 9637 ada_evaluate_subexp (NULL, exp, pos, 9638 EVAL_NORMAL)); 9639 9640 value_free_to_mark (mark); 9641} 9642 9643/* Assuming that LHS represents an lvalue having a record or array 9644 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment 9645 of that aggregate's value to LHS, advancing *POS past the 9646 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an 9647 lvalue containing LHS (possibly LHS itself). Does not modify 9648 the inferior's memory, nor does it modify the contents of 9649 LHS (unless == CONTAINER). Returns the modified CONTAINER. */ 9650 9651static struct value * 9652assign_aggregate (struct value *container, 9653 struct value *lhs, struct expression *exp, 9654 int *pos, enum noside noside) 9655{ 9656 struct type *lhs_type; 9657 int n = exp->elts[*pos+1].longconst; 9658 LONGEST low_index, high_index; 9659 int num_specs; 9660 LONGEST *indices; 9661 int max_indices, num_indices; 9662 int i; 9663 9664 *pos += 3; 9665 if (noside != EVAL_NORMAL) 9666 { 9667 for (i = 0; i < n; i += 1) 9668 ada_evaluate_subexp (NULL, exp, pos, noside); 9669 return container; 9670 } 9671 9672 container = ada_coerce_ref (container); 9673 if (ada_is_direct_array_type (value_type (container))) 9674 container = ada_coerce_to_simple_array (container); 9675 lhs = ada_coerce_ref (lhs); 9676 if (!deprecated_value_modifiable (lhs)) 9677 error (_("Left operand of assignment is not a modifiable lvalue.")); 9678 9679 lhs_type = value_type (lhs); 9680 if (ada_is_direct_array_type (lhs_type)) 9681 { 9682 lhs = ada_coerce_to_simple_array (lhs); 9683 lhs_type = value_type (lhs); 9684 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type); 9685 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type); 9686 } 9687 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT) 9688 { 9689 low_index = 0; 9690 high_index = num_visible_fields (lhs_type) - 1; 9691 } 9692 else 9693 error (_("Left-hand side must be array or record.")); 9694 9695 num_specs = num_component_specs (exp, *pos - 3); 9696 max_indices = 4 * num_specs + 4; 9697 indices = alloca (max_indices * sizeof (indices[0])); 9698 indices[0] = indices[1] = low_index - 1; 9699 indices[2] = indices[3] = high_index + 1; 9700 num_indices = 4; 9701 9702 for (i = 0; i < n; i += 1) 9703 { 9704 switch (exp->elts[*pos].opcode) 9705 { 9706 case OP_CHOICES: 9707 aggregate_assign_from_choices (container, lhs, exp, pos, indices, 9708 &num_indices, max_indices, 9709 low_index, high_index); 9710 break; 9711 case OP_POSITIONAL: 9712 aggregate_assign_positional (container, lhs, exp, pos, indices, 9713 &num_indices, max_indices, 9714 low_index, high_index); 9715 break; 9716 case OP_OTHERS: 9717 if (i != n-1) 9718 error (_("Misplaced 'others' clause")); 9719 aggregate_assign_others (container, lhs, exp, pos, indices, 9720 num_indices, low_index, high_index); 9721 break; 9722 default: 9723 error (_("Internal error: bad aggregate clause")); 9724 } 9725 } 9726 9727 return container; 9728} 9729 9730/* Assign into the component of LHS indexed by the OP_POSITIONAL 9731 construct at *POS, updating *POS past the construct, given that 9732 the positions are relative to lower bound LOW, where HIGH is the 9733 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1] 9734 updating *NUM_INDICES as needed. CONTAINER is as for 9735 assign_aggregate. */ 9736static void 9737aggregate_assign_positional (struct value *container, 9738 struct value *lhs, struct expression *exp, 9739 int *pos, LONGEST *indices, int *num_indices, 9740 int max_indices, LONGEST low, LONGEST high) 9741{ 9742 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low; 9743 9744 if (ind - 1 == high) 9745 warning (_("Extra components in aggregate ignored.")); 9746 if (ind <= high) 9747 { 9748 add_component_interval (ind, ind, indices, num_indices, max_indices); 9749 *pos += 3; 9750 assign_component (container, lhs, ind, exp, pos); 9751 } 9752 else 9753 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 9754} 9755 9756/* Assign into the components of LHS indexed by the OP_CHOICES 9757 construct at *POS, updating *POS past the construct, given that 9758 the allowable indices are LOW..HIGH. Record the indices assigned 9759 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as 9760 needed. CONTAINER is as for assign_aggregate. */ 9761static void 9762aggregate_assign_from_choices (struct value *container, 9763 struct value *lhs, struct expression *exp, 9764 int *pos, LONGEST *indices, int *num_indices, 9765 int max_indices, LONGEST low, LONGEST high) 9766{ 9767 int j; 9768 int n_choices = longest_to_int (exp->elts[*pos+1].longconst); 9769 int choice_pos, expr_pc; 9770 int is_array = ada_is_direct_array_type (value_type (lhs)); 9771 9772 choice_pos = *pos += 3; 9773 9774 for (j = 0; j < n_choices; j += 1) 9775 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 9776 expr_pc = *pos; 9777 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 9778 9779 for (j = 0; j < n_choices; j += 1) 9780 { 9781 LONGEST lower, upper; 9782 enum exp_opcode op = exp->elts[choice_pos].opcode; 9783 9784 if (op == OP_DISCRETE_RANGE) 9785 { 9786 choice_pos += 1; 9787 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos, 9788 EVAL_NORMAL)); 9789 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos, 9790 EVAL_NORMAL)); 9791 } 9792 else if (is_array) 9793 { 9794 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos, 9795 EVAL_NORMAL)); 9796 upper = lower; 9797 } 9798 else 9799 { 9800 int ind; 9801 const char *name; 9802 9803 switch (op) 9804 { 9805 case OP_NAME: 9806 name = &exp->elts[choice_pos + 2].string; 9807 break; 9808 case OP_VAR_VALUE: 9809 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol); 9810 break; 9811 default: 9812 error (_("Invalid record component association.")); 9813 } 9814 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP); 9815 ind = 0; 9816 if (! find_struct_field (name, value_type (lhs), 0, 9817 NULL, NULL, NULL, NULL, &ind)) 9818 error (_("Unknown component name: %s."), name); 9819 lower = upper = ind; 9820 } 9821 9822 if (lower <= upper && (lower < low || upper > high)) 9823 error (_("Index in component association out of bounds.")); 9824 9825 add_component_interval (lower, upper, indices, num_indices, 9826 max_indices); 9827 while (lower <= upper) 9828 { 9829 int pos1; 9830 9831 pos1 = expr_pc; 9832 assign_component (container, lhs, lower, exp, &pos1); 9833 lower += 1; 9834 } 9835 } 9836} 9837 9838/* Assign the value of the expression in the OP_OTHERS construct in 9839 EXP at *POS into the components of LHS indexed from LOW .. HIGH that 9840 have not been previously assigned. The index intervals already assigned 9841 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the 9842 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */ 9843static void 9844aggregate_assign_others (struct value *container, 9845 struct value *lhs, struct expression *exp, 9846 int *pos, LONGEST *indices, int num_indices, 9847 LONGEST low, LONGEST high) 9848{ 9849 int i; 9850 int expr_pc = *pos + 1; 9851 9852 for (i = 0; i < num_indices - 2; i += 2) 9853 { 9854 LONGEST ind; 9855 9856 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1) 9857 { 9858 int localpos; 9859 9860 localpos = expr_pc; 9861 assign_component (container, lhs, ind, exp, &localpos); 9862 } 9863 } 9864 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); 9865} 9866 9867/* Add the interval [LOW .. HIGH] to the sorted set of intervals 9868 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ], 9869 modifying *SIZE as needed. It is an error if *SIZE exceeds 9870 MAX_SIZE. The resulting intervals do not overlap. */ 9871static void 9872add_component_interval (LONGEST low, LONGEST high, 9873 LONGEST* indices, int *size, int max_size) 9874{ 9875 int i, j; 9876 9877 for (i = 0; i < *size; i += 2) { 9878 if (high >= indices[i] && low <= indices[i + 1]) 9879 { 9880 int kh; 9881 9882 for (kh = i + 2; kh < *size; kh += 2) 9883 if (high < indices[kh]) 9884 break; 9885 if (low < indices[i]) 9886 indices[i] = low; 9887 indices[i + 1] = indices[kh - 1]; 9888 if (high > indices[i + 1]) 9889 indices[i + 1] = high; 9890 memcpy (indices + i + 2, indices + kh, *size - kh); 9891 *size -= kh - i - 2; 9892 return; 9893 } 9894 else if (high < indices[i]) 9895 break; 9896 } 9897 9898 if (*size == max_size) 9899 error (_("Internal error: miscounted aggregate components.")); 9900 *size += 2; 9901 for (j = *size-1; j >= i+2; j -= 1) 9902 indices[j] = indices[j - 2]; 9903 indices[i] = low; 9904 indices[i + 1] = high; 9905} 9906 9907/* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2 9908 is different. */ 9909 9910static struct value * 9911ada_value_cast (struct type *type, struct value *arg2, enum noside noside) 9912{ 9913 if (type == ada_check_typedef (value_type (arg2))) 9914 return arg2; 9915 9916 if (ada_is_fixed_point_type (type)) 9917 return (cast_to_fixed (type, arg2)); 9918 9919 if (ada_is_fixed_point_type (value_type (arg2))) 9920 return cast_from_fixed (type, arg2); 9921 9922 return value_cast (type, arg2); 9923} 9924 9925/* Evaluating Ada expressions, and printing their result. 9926 ------------------------------------------------------ 9927 9928 1. Introduction: 9929 ---------------- 9930 9931 We usually evaluate an Ada expression in order to print its value. 9932 We also evaluate an expression in order to print its type, which 9933 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation, 9934 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the 9935 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of 9936 the evaluation compared to the EVAL_NORMAL, but is otherwise very 9937 similar. 9938 9939 Evaluating expressions is a little more complicated for Ada entities 9940 than it is for entities in languages such as C. The main reason for 9941 this is that Ada provides types whose definition might be dynamic. 9942 One example of such types is variant records. Or another example 9943 would be an array whose bounds can only be known at run time. 9944 9945 The following description is a general guide as to what should be 9946 done (and what should NOT be done) in order to evaluate an expression 9947 involving such types, and when. This does not cover how the semantic 9948 information is encoded by GNAT as this is covered separatly. For the 9949 document used as the reference for the GNAT encoding, see exp_dbug.ads 9950 in the GNAT sources. 9951 9952 Ideally, we should embed each part of this description next to its 9953 associated code. Unfortunately, the amount of code is so vast right 9954 now that it's hard to see whether the code handling a particular 9955 situation might be duplicated or not. One day, when the code is 9956 cleaned up, this guide might become redundant with the comments 9957 inserted in the code, and we might want to remove it. 9958 9959 2. ``Fixing'' an Entity, the Simple Case: 9960 ----------------------------------------- 9961 9962 When evaluating Ada expressions, the tricky issue is that they may 9963 reference entities whose type contents and size are not statically 9964 known. Consider for instance a variant record: 9965 9966 type Rec (Empty : Boolean := True) is record 9967 case Empty is 9968 when True => null; 9969 when False => Value : Integer; 9970 end case; 9971 end record; 9972 Yes : Rec := (Empty => False, Value => 1); 9973 No : Rec := (empty => True); 9974 9975 The size and contents of that record depends on the value of the 9976 descriminant (Rec.Empty). At this point, neither the debugging 9977 information nor the associated type structure in GDB are able to 9978 express such dynamic types. So what the debugger does is to create 9979 "fixed" versions of the type that applies to the specific object. 9980 We also informally refer to this opperation as "fixing" an object, 9981 which means creating its associated fixed type. 9982 9983 Example: when printing the value of variable "Yes" above, its fixed 9984 type would look like this: 9985 9986 type Rec is record 9987 Empty : Boolean; 9988 Value : Integer; 9989 end record; 9990 9991 On the other hand, if we printed the value of "No", its fixed type 9992 would become: 9993 9994 type Rec is record 9995 Empty : Boolean; 9996 end record; 9997 9998 Things become a little more complicated when trying to fix an entity 9999 with a dynamic type that directly contains another dynamic type, 10000 such as an array of variant records, for instance. There are 10001 two possible cases: Arrays, and records. 10002 10003 3. ``Fixing'' Arrays: 10004 --------------------- 10005 10006 The type structure in GDB describes an array in terms of its bounds, 10007 and the type of its elements. By design, all elements in the array 10008 have the same type and we cannot represent an array of variant elements 10009 using the current type structure in GDB. When fixing an array, 10010 we cannot fix the array element, as we would potentially need one 10011 fixed type per element of the array. As a result, the best we can do 10012 when fixing an array is to produce an array whose bounds and size 10013 are correct (allowing us to read it from memory), but without having 10014 touched its element type. Fixing each element will be done later, 10015 when (if) necessary. 10016 10017 Arrays are a little simpler to handle than records, because the same 10018 amount of memory is allocated for each element of the array, even if 10019 the amount of space actually used by each element differs from element 10020 to element. Consider for instance the following array of type Rec: 10021 10022 type Rec_Array is array (1 .. 2) of Rec; 10023 10024 The actual amount of memory occupied by each element might be different 10025 from element to element, depending on the value of their discriminant. 10026 But the amount of space reserved for each element in the array remains 10027 fixed regardless. So we simply need to compute that size using 10028 the debugging information available, from which we can then determine 10029 the array size (we multiply the number of elements of the array by 10030 the size of each element). 10031 10032 The simplest case is when we have an array of a constrained element 10033 type. For instance, consider the following type declarations: 10034 10035 type Bounded_String (Max_Size : Integer) is 10036 Length : Integer; 10037 Buffer : String (1 .. Max_Size); 10038 end record; 10039 type Bounded_String_Array is array (1 ..2) of Bounded_String (80); 10040 10041 In this case, the compiler describes the array as an array of 10042 variable-size elements (identified by its XVS suffix) for which 10043 the size can be read in the parallel XVZ variable. 10044 10045 In the case of an array of an unconstrained element type, the compiler 10046 wraps the array element inside a private PAD type. This type should not 10047 be shown to the user, and must be "unwrap"'ed before printing. Note 10048 that we also use the adjective "aligner" in our code to designate 10049 these wrapper types. 10050 10051 In some cases, the size allocated for each element is statically 10052 known. In that case, the PAD type already has the correct size, 10053 and the array element should remain unfixed. 10054 10055 But there are cases when this size is not statically known. 10056 For instance, assuming that "Five" is an integer variable: 10057 10058 type Dynamic is array (1 .. Five) of Integer; 10059 type Wrapper (Has_Length : Boolean := False) is record 10060 Data : Dynamic; 10061 case Has_Length is 10062 when True => Length : Integer; 10063 when False => null; 10064 end case; 10065 end record; 10066 type Wrapper_Array is array (1 .. 2) of Wrapper; 10067 10068 Hello : Wrapper_Array := (others => (Has_Length => True, 10069 Data => (others => 17), 10070 Length => 1)); 10071 10072 10073 The debugging info would describe variable Hello as being an 10074 array of a PAD type. The size of that PAD type is not statically 10075 known, but can be determined using a parallel XVZ variable. 10076 In that case, a copy of the PAD type with the correct size should 10077 be used for the fixed array. 10078 10079 3. ``Fixing'' record type objects: 10080 ---------------------------------- 10081 10082 Things are slightly different from arrays in the case of dynamic 10083 record types. In this case, in order to compute the associated 10084 fixed type, we need to determine the size and offset of each of 10085 its components. This, in turn, requires us to compute the fixed 10086 type of each of these components. 10087 10088 Consider for instance the example: 10089 10090 type Bounded_String (Max_Size : Natural) is record 10091 Str : String (1 .. Max_Size); 10092 Length : Natural; 10093 end record; 10094 My_String : Bounded_String (Max_Size => 10); 10095 10096 In that case, the position of field "Length" depends on the size 10097 of field Str, which itself depends on the value of the Max_Size 10098 discriminant. In order to fix the type of variable My_String, 10099 we need to fix the type of field Str. Therefore, fixing a variant 10100 record requires us to fix each of its components. 10101 10102 However, if a component does not have a dynamic size, the component 10103 should not be fixed. In particular, fields that use a PAD type 10104 should not fixed. Here is an example where this might happen 10105 (assuming type Rec above): 10106 10107 type Container (Big : Boolean) is record 10108 First : Rec; 10109 After : Integer; 10110 case Big is 10111 when True => Another : Integer; 10112 when False => null; 10113 end case; 10114 end record; 10115 My_Container : Container := (Big => False, 10116 First => (Empty => True), 10117 After => 42); 10118 10119 In that example, the compiler creates a PAD type for component First, 10120 whose size is constant, and then positions the component After just 10121 right after it. The offset of component After is therefore constant 10122 in this case. 10123 10124 The debugger computes the position of each field based on an algorithm 10125 that uses, among other things, the actual position and size of the field 10126 preceding it. Let's now imagine that the user is trying to print 10127 the value of My_Container. If the type fixing was recursive, we would 10128 end up computing the offset of field After based on the size of the 10129 fixed version of field First. And since in our example First has 10130 only one actual field, the size of the fixed type is actually smaller 10131 than the amount of space allocated to that field, and thus we would 10132 compute the wrong offset of field After. 10133 10134 To make things more complicated, we need to watch out for dynamic 10135 components of variant records (identified by the ___XVL suffix in 10136 the component name). Even if the target type is a PAD type, the size 10137 of that type might not be statically known. So the PAD type needs 10138 to be unwrapped and the resulting type needs to be fixed. Otherwise, 10139 we might end up with the wrong size for our component. This can be 10140 observed with the following type declarations: 10141 10142 type Octal is new Integer range 0 .. 7; 10143 type Octal_Array is array (Positive range <>) of Octal; 10144 pragma Pack (Octal_Array); 10145 10146 type Octal_Buffer (Size : Positive) is record 10147 Buffer : Octal_Array (1 .. Size); 10148 Length : Integer; 10149 end record; 10150 10151 In that case, Buffer is a PAD type whose size is unset and needs 10152 to be computed by fixing the unwrapped type. 10153 10154 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity: 10155 ---------------------------------------------------------- 10156 10157 Lastly, when should the sub-elements of an entity that remained unfixed 10158 thus far, be actually fixed? 10159 10160 The answer is: Only when referencing that element. For instance 10161 when selecting one component of a record, this specific component 10162 should be fixed at that point in time. Or when printing the value 10163 of a record, each component should be fixed before its value gets 10164 printed. Similarly for arrays, the element of the array should be 10165 fixed when printing each element of the array, or when extracting 10166 one element out of that array. On the other hand, fixing should 10167 not be performed on the elements when taking a slice of an array! 10168 10169 Note that one of the side-effects of miscomputing the offset and 10170 size of each field is that we end up also miscomputing the size 10171 of the containing type. This can have adverse results when computing 10172 the value of an entity. GDB fetches the value of an entity based 10173 on the size of its type, and thus a wrong size causes GDB to fetch 10174 the wrong amount of memory. In the case where the computed size is 10175 too small, GDB fetches too little data to print the value of our 10176 entiry. Results in this case as unpredicatble, as we usually read 10177 past the buffer containing the data =:-o. */ 10178 10179/* Implement the evaluate_exp routine in the exp_descriptor structure 10180 for the Ada language. */ 10181 10182static struct value * 10183ada_evaluate_subexp (struct type *expect_type, struct expression *exp, 10184 int *pos, enum noside noside) 10185{ 10186 enum exp_opcode op; 10187 int tem; 10188 int pc; 10189 int preeval_pos; 10190 struct value *arg1 = NULL, *arg2 = NULL, *arg3; 10191 struct type *type; 10192 int nargs, oplen; 10193 struct value **argvec; 10194 10195 pc = *pos; 10196 *pos += 1; 10197 op = exp->elts[pc].opcode; 10198 10199 switch (op) 10200 { 10201 default: 10202 *pos -= 1; 10203 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside); 10204 10205 if (noside == EVAL_NORMAL) 10206 arg1 = unwrap_value (arg1); 10207 10208 /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided, 10209 then we need to perform the conversion manually, because 10210 evaluate_subexp_standard doesn't do it. This conversion is 10211 necessary in Ada because the different kinds of float/fixed 10212 types in Ada have different representations. 10213 10214 Similarly, we need to perform the conversion from OP_LONG 10215 ourselves. */ 10216 if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL) 10217 arg1 = ada_value_cast (expect_type, arg1, noside); 10218 10219 return arg1; 10220 10221 case OP_STRING: 10222 { 10223 struct value *result; 10224 10225 *pos -= 1; 10226 result = evaluate_subexp_standard (expect_type, exp, pos, noside); 10227 /* The result type will have code OP_STRING, bashed there from 10228 OP_ARRAY. Bash it back. */ 10229 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING) 10230 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY; 10231 return result; 10232 } 10233 10234 case UNOP_CAST: 10235 (*pos) += 2; 10236 type = exp->elts[pc + 1].type; 10237 arg1 = evaluate_subexp (type, exp, pos, noside); 10238 if (noside == EVAL_SKIP) 10239 goto nosideret; 10240 arg1 = ada_value_cast (type, arg1, noside); 10241 return arg1; 10242 10243 case UNOP_QUAL: 10244 (*pos) += 2; 10245 type = exp->elts[pc + 1].type; 10246 return ada_evaluate_subexp (type, exp, pos, noside); 10247 10248 case BINOP_ASSIGN: 10249 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10250 if (exp->elts[*pos].opcode == OP_AGGREGATE) 10251 { 10252 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside); 10253 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS) 10254 return arg1; 10255 return ada_value_assign (arg1, arg1); 10256 } 10257 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1, 10258 except if the lhs of our assignment is a convenience variable. 10259 In the case of assigning to a convenience variable, the lhs 10260 should be exactly the result of the evaluation of the rhs. */ 10261 type = value_type (arg1); 10262 if (VALUE_LVAL (arg1) == lval_internalvar) 10263 type = NULL; 10264 arg2 = evaluate_subexp (type, exp, pos, noside); 10265 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS) 10266 return arg1; 10267 if (ada_is_fixed_point_type (value_type (arg1))) 10268 arg2 = cast_to_fixed (value_type (arg1), arg2); 10269 else if (ada_is_fixed_point_type (value_type (arg2))) 10270 error 10271 (_("Fixed-point values must be assigned to fixed-point variables")); 10272 else 10273 arg2 = coerce_for_assign (value_type (arg1), arg2); 10274 return ada_value_assign (arg1, arg2); 10275 10276 case BINOP_ADD: 10277 arg1 = evaluate_subexp_with_coercion (exp, pos, noside); 10278 arg2 = evaluate_subexp_with_coercion (exp, pos, noside); 10279 if (noside == EVAL_SKIP) 10280 goto nosideret; 10281 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR) 10282 return (value_from_longest 10283 (value_type (arg1), 10284 value_as_long (arg1) + value_as_long (arg2))); 10285 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR) 10286 return (value_from_longest 10287 (value_type (arg2), 10288 value_as_long (arg1) + value_as_long (arg2))); 10289 if ((ada_is_fixed_point_type (value_type (arg1)) 10290 || ada_is_fixed_point_type (value_type (arg2))) 10291 && value_type (arg1) != value_type (arg2)) 10292 error (_("Operands of fixed-point addition must have the same type")); 10293 /* Do the addition, and cast the result to the type of the first 10294 argument. We cannot cast the result to a reference type, so if 10295 ARG1 is a reference type, find its underlying type. */ 10296 type = value_type (arg1); 10297 while (TYPE_CODE (type) == TYPE_CODE_REF) 10298 type = TYPE_TARGET_TYPE (type); 10299 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10300 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD)); 10301 10302 case BINOP_SUB: 10303 arg1 = evaluate_subexp_with_coercion (exp, pos, noside); 10304 arg2 = evaluate_subexp_with_coercion (exp, pos, noside); 10305 if (noside == EVAL_SKIP) 10306 goto nosideret; 10307 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR) 10308 return (value_from_longest 10309 (value_type (arg1), 10310 value_as_long (arg1) - value_as_long (arg2))); 10311 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR) 10312 return (value_from_longest 10313 (value_type (arg2), 10314 value_as_long (arg1) - value_as_long (arg2))); 10315 if ((ada_is_fixed_point_type (value_type (arg1)) 10316 || ada_is_fixed_point_type (value_type (arg2))) 10317 && value_type (arg1) != value_type (arg2)) 10318 error (_("Operands of fixed-point subtraction " 10319 "must have the same type")); 10320 /* Do the substraction, and cast the result to the type of the first 10321 argument. We cannot cast the result to a reference type, so if 10322 ARG1 is a reference type, find its underlying type. */ 10323 type = value_type (arg1); 10324 while (TYPE_CODE (type) == TYPE_CODE_REF) 10325 type = TYPE_TARGET_TYPE (type); 10326 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10327 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB)); 10328 10329 case BINOP_MUL: 10330 case BINOP_DIV: 10331 case BINOP_REM: 10332 case BINOP_MOD: 10333 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10334 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10335 if (noside == EVAL_SKIP) 10336 goto nosideret; 10337 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 10338 { 10339 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10340 return value_zero (value_type (arg1), not_lval); 10341 } 10342 else 10343 { 10344 type = builtin_type (exp->gdbarch)->builtin_double; 10345 if (ada_is_fixed_point_type (value_type (arg1))) 10346 arg1 = cast_from_fixed (type, arg1); 10347 if (ada_is_fixed_point_type (value_type (arg2))) 10348 arg2 = cast_from_fixed (type, arg2); 10349 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10350 return ada_value_binop (arg1, arg2, op); 10351 } 10352 10353 case BINOP_EQUAL: 10354 case BINOP_NOTEQUAL: 10355 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10356 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); 10357 if (noside == EVAL_SKIP) 10358 goto nosideret; 10359 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10360 tem = 0; 10361 else 10362 { 10363 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10364 tem = ada_value_equal (arg1, arg2); 10365 } 10366 if (op == BINOP_NOTEQUAL) 10367 tem = !tem; 10368 type = language_bool_type (exp->language_defn, exp->gdbarch); 10369 return value_from_longest (type, (LONGEST) tem); 10370 10371 case UNOP_NEG: 10372 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10373 if (noside == EVAL_SKIP) 10374 goto nosideret; 10375 else if (ada_is_fixed_point_type (value_type (arg1))) 10376 return value_cast (value_type (arg1), value_neg (arg1)); 10377 else 10378 { 10379 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 10380 return value_neg (arg1); 10381 } 10382 10383 case BINOP_LOGICAL_AND: 10384 case BINOP_LOGICAL_OR: 10385 case UNOP_LOGICAL_NOT: 10386 { 10387 struct value *val; 10388 10389 *pos -= 1; 10390 val = evaluate_subexp_standard (expect_type, exp, pos, noside); 10391 type = language_bool_type (exp->language_defn, exp->gdbarch); 10392 return value_cast (type, val); 10393 } 10394 10395 case BINOP_BITWISE_AND: 10396 case BINOP_BITWISE_IOR: 10397 case BINOP_BITWISE_XOR: 10398 { 10399 struct value *val; 10400 10401 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS); 10402 *pos = pc; 10403 val = evaluate_subexp_standard (expect_type, exp, pos, noside); 10404 10405 return value_cast (value_type (arg1), val); 10406 } 10407 10408 case OP_VAR_VALUE: 10409 *pos -= 1; 10410 10411 if (noside == EVAL_SKIP) 10412 { 10413 *pos += 4; 10414 goto nosideret; 10415 } 10416 10417 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN) 10418 /* Only encountered when an unresolved symbol occurs in a 10419 context other than a function call, in which case, it is 10420 invalid. */ 10421 error (_("Unexpected unresolved symbol, %s, during evaluation"), 10422 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); 10423 10424 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10425 { 10426 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol)); 10427 /* Check to see if this is a tagged type. We also need to handle 10428 the case where the type is a reference to a tagged type, but 10429 we have to be careful to exclude pointers to tagged types. 10430 The latter should be shown as usual (as a pointer), whereas 10431 a reference should mostly be transparent to the user. */ 10432 if (ada_is_tagged_type (type, 0) 10433 || (TYPE_CODE (type) == TYPE_CODE_REF 10434 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))) 10435 { 10436 /* Tagged types are a little special in the fact that the real 10437 type is dynamic and can only be determined by inspecting the 10438 object's tag. This means that we need to get the object's 10439 value first (EVAL_NORMAL) and then extract the actual object 10440 type from its tag. 10441 10442 Note that we cannot skip the final step where we extract 10443 the object type from its tag, because the EVAL_NORMAL phase 10444 results in dynamic components being resolved into fixed ones. 10445 This can cause problems when trying to print the type 10446 description of tagged types whose parent has a dynamic size: 10447 We use the type name of the "_parent" component in order 10448 to print the name of the ancestor type in the type description. 10449 If that component had a dynamic size, the resolution into 10450 a fixed type would result in the loss of that type name, 10451 thus preventing us from printing the name of the ancestor 10452 type in the type description. */ 10453 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL); 10454 10455 if (TYPE_CODE (type) != TYPE_CODE_REF) 10456 { 10457 struct type *actual_type; 10458 10459 actual_type = type_from_tag (ada_value_tag (arg1)); 10460 if (actual_type == NULL) 10461 /* If, for some reason, we were unable to determine 10462 the actual type from the tag, then use the static 10463 approximation that we just computed as a fallback. 10464 This can happen if the debugging information is 10465 incomplete, for instance. */ 10466 actual_type = type; 10467 return value_zero (actual_type, not_lval); 10468 } 10469 else 10470 { 10471 /* In the case of a ref, ada_coerce_ref takes care 10472 of determining the actual type. But the evaluation 10473 should return a ref as it should be valid to ask 10474 for its address; so rebuild a ref after coerce. */ 10475 arg1 = ada_coerce_ref (arg1); 10476 return value_ref (arg1); 10477 } 10478 } 10479 10480 /* Records and unions for which GNAT encodings have been 10481 generated need to be statically fixed as well. 10482 Otherwise, non-static fixing produces a type where 10483 all dynamic properties are removed, which prevents "ptype" 10484 from being able to completely describe the type. 10485 For instance, a case statement in a variant record would be 10486 replaced by the relevant components based on the actual 10487 value of the discriminants. */ 10488 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT 10489 && dynamic_template_type (type) != NULL) 10490 || (TYPE_CODE (type) == TYPE_CODE_UNION 10491 && ada_find_parallel_type (type, "___XVU") != NULL)) 10492 { 10493 *pos += 4; 10494 return value_zero (to_static_fixed_type (type), not_lval); 10495 } 10496 } 10497 10498 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside); 10499 return ada_to_fixed_value (arg1); 10500 10501 case OP_FUNCALL: 10502 (*pos) += 2; 10503 10504 /* Allocate arg vector, including space for the function to be 10505 called in argvec[0] and a terminating NULL. */ 10506 nargs = longest_to_int (exp->elts[pc + 1].longconst); 10507 argvec = 10508 (struct value **) alloca (sizeof (struct value *) * (nargs + 2)); 10509 10510 if (exp->elts[*pos].opcode == OP_VAR_VALUE 10511 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN) 10512 error (_("Unexpected unresolved symbol, %s, during evaluation"), 10513 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol)); 10514 else 10515 { 10516 for (tem = 0; tem <= nargs; tem += 1) 10517 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10518 argvec[tem] = 0; 10519 10520 if (noside == EVAL_SKIP) 10521 goto nosideret; 10522 } 10523 10524 if (ada_is_constrained_packed_array_type 10525 (desc_base_type (value_type (argvec[0])))) 10526 argvec[0] = ada_coerce_to_simple_array (argvec[0]); 10527 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY 10528 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0) 10529 /* This is a packed array that has already been fixed, and 10530 therefore already coerced to a simple array. Nothing further 10531 to do. */ 10532 ; 10533 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF 10534 || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY 10535 && VALUE_LVAL (argvec[0]) == lval_memory)) 10536 argvec[0] = value_addr (argvec[0]); 10537 10538 type = ada_check_typedef (value_type (argvec[0])); 10539 10540 /* Ada allows us to implicitly dereference arrays when subscripting 10541 them. So, if this is an array typedef (encoding use for array 10542 access types encoded as fat pointers), strip it now. */ 10543 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) 10544 type = ada_typedef_target_type (type); 10545 10546 if (TYPE_CODE (type) == TYPE_CODE_PTR) 10547 { 10548 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))) 10549 { 10550 case TYPE_CODE_FUNC: 10551 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 10552 break; 10553 case TYPE_CODE_ARRAY: 10554 break; 10555 case TYPE_CODE_STRUCT: 10556 if (noside != EVAL_AVOID_SIDE_EFFECTS) 10557 argvec[0] = ada_value_ind (argvec[0]); 10558 type = ada_check_typedef (TYPE_TARGET_TYPE (type)); 10559 break; 10560 default: 10561 error (_("cannot subscript or call something of type `%s'"), 10562 ada_type_name (value_type (argvec[0]))); 10563 break; 10564 } 10565 } 10566 10567 switch (TYPE_CODE (type)) 10568 { 10569 case TYPE_CODE_FUNC: 10570 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10571 { 10572 struct type *rtype = TYPE_TARGET_TYPE (type); 10573 10574 if (TYPE_GNU_IFUNC (type)) 10575 return allocate_value (TYPE_TARGET_TYPE (rtype)); 10576 return allocate_value (rtype); 10577 } 10578 return call_function_by_hand (argvec[0], nargs, argvec + 1); 10579 case TYPE_CODE_INTERNAL_FUNCTION: 10580 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10581 /* We don't know anything about what the internal 10582 function might return, but we have to return 10583 something. */ 10584 return value_zero (builtin_type (exp->gdbarch)->builtin_int, 10585 not_lval); 10586 else 10587 return call_internal_function (exp->gdbarch, exp->language_defn, 10588 argvec[0], nargs, argvec + 1); 10589 10590 case TYPE_CODE_STRUCT: 10591 { 10592 int arity; 10593 10594 arity = ada_array_arity (type); 10595 type = ada_array_element_type (type, nargs); 10596 if (type == NULL) 10597 error (_("cannot subscript or call a record")); 10598 if (arity != nargs) 10599 error (_("wrong number of subscripts; expecting %d"), arity); 10600 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10601 return value_zero (ada_aligned_type (type), lval_memory); 10602 return 10603 unwrap_value (ada_value_subscript 10604 (argvec[0], nargs, argvec + 1)); 10605 } 10606 case TYPE_CODE_ARRAY: 10607 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10608 { 10609 type = ada_array_element_type (type, nargs); 10610 if (type == NULL) 10611 error (_("element type of array unknown")); 10612 else 10613 return value_zero (ada_aligned_type (type), lval_memory); 10614 } 10615 return 10616 unwrap_value (ada_value_subscript 10617 (ada_coerce_to_simple_array (argvec[0]), 10618 nargs, argvec + 1)); 10619 case TYPE_CODE_PTR: /* Pointer to array */ 10620 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10621 { 10622 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1); 10623 type = ada_array_element_type (type, nargs); 10624 if (type == NULL) 10625 error (_("element type of array unknown")); 10626 else 10627 return value_zero (ada_aligned_type (type), lval_memory); 10628 } 10629 return 10630 unwrap_value (ada_value_ptr_subscript (argvec[0], 10631 nargs, argvec + 1)); 10632 10633 default: 10634 error (_("Attempt to index or call something other than an " 10635 "array or function")); 10636 } 10637 10638 case TERNOP_SLICE: 10639 { 10640 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10641 struct value *low_bound_val = 10642 evaluate_subexp (NULL_TYPE, exp, pos, noside); 10643 struct value *high_bound_val = 10644 evaluate_subexp (NULL_TYPE, exp, pos, noside); 10645 LONGEST low_bound; 10646 LONGEST high_bound; 10647 10648 low_bound_val = coerce_ref (low_bound_val); 10649 high_bound_val = coerce_ref (high_bound_val); 10650 low_bound = value_as_long (low_bound_val); 10651 high_bound = value_as_long (high_bound_val); 10652 10653 if (noside == EVAL_SKIP) 10654 goto nosideret; 10655 10656 /* If this is a reference to an aligner type, then remove all 10657 the aligners. */ 10658 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF 10659 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array)))) 10660 TYPE_TARGET_TYPE (value_type (array)) = 10661 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array))); 10662 10663 if (ada_is_constrained_packed_array_type (value_type (array))) 10664 error (_("cannot slice a packed array")); 10665 10666 /* If this is a reference to an array or an array lvalue, 10667 convert to a pointer. */ 10668 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF 10669 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY 10670 && VALUE_LVAL (array) == lval_memory)) 10671 array = value_addr (array); 10672 10673 if (noside == EVAL_AVOID_SIDE_EFFECTS 10674 && ada_is_array_descriptor_type (ada_check_typedef 10675 (value_type (array)))) 10676 return empty_array (ada_type_of_array (array, 0), low_bound); 10677 10678 array = ada_coerce_to_simple_array_ptr (array); 10679 10680 /* If we have more than one level of pointer indirection, 10681 dereference the value until we get only one level. */ 10682 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR 10683 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array))) 10684 == TYPE_CODE_PTR)) 10685 array = value_ind (array); 10686 10687 /* Make sure we really do have an array type before going further, 10688 to avoid a SEGV when trying to get the index type or the target 10689 type later down the road if the debug info generated by 10690 the compiler is incorrect or incomplete. */ 10691 if (!ada_is_simple_array_type (value_type (array))) 10692 error (_("cannot take slice of non-array")); 10693 10694 if (TYPE_CODE (ada_check_typedef (value_type (array))) 10695 == TYPE_CODE_PTR) 10696 { 10697 struct type *type0 = ada_check_typedef (value_type (array)); 10698 10699 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS) 10700 return empty_array (TYPE_TARGET_TYPE (type0), low_bound); 10701 else 10702 { 10703 struct type *arr_type0 = 10704 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1); 10705 10706 return ada_value_slice_from_ptr (array, arr_type0, 10707 longest_to_int (low_bound), 10708 longest_to_int (high_bound)); 10709 } 10710 } 10711 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 10712 return array; 10713 else if (high_bound < low_bound) 10714 return empty_array (value_type (array), low_bound); 10715 else 10716 return ada_value_slice (array, longest_to_int (low_bound), 10717 longest_to_int (high_bound)); 10718 } 10719 10720 case UNOP_IN_RANGE: 10721 (*pos) += 2; 10722 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10723 type = check_typedef (exp->elts[pc + 1].type); 10724 10725 if (noside == EVAL_SKIP) 10726 goto nosideret; 10727 10728 switch (TYPE_CODE (type)) 10729 { 10730 default: 10731 lim_warning (_("Membership test incompletely implemented; " 10732 "always returns true")); 10733 type = language_bool_type (exp->language_defn, exp->gdbarch); 10734 return value_from_longest (type, (LONGEST) 1); 10735 10736 case TYPE_CODE_RANGE: 10737 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type)); 10738 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type)); 10739 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10740 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 10741 type = language_bool_type (exp->language_defn, exp->gdbarch); 10742 return 10743 value_from_longest (type, 10744 (value_less (arg1, arg3) 10745 || value_equal (arg1, arg3)) 10746 && (value_less (arg2, arg1) 10747 || value_equal (arg2, arg1))); 10748 } 10749 10750 case BINOP_IN_BOUNDS: 10751 (*pos) += 2; 10752 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10753 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10754 10755 if (noside == EVAL_SKIP) 10756 goto nosideret; 10757 10758 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10759 { 10760 type = language_bool_type (exp->language_defn, exp->gdbarch); 10761 return value_zero (type, not_lval); 10762 } 10763 10764 tem = longest_to_int (exp->elts[pc + 1].longconst); 10765 10766 type = ada_index_type (value_type (arg2), tem, "range"); 10767 if (!type) 10768 type = value_type (arg1); 10769 10770 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1)); 10771 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0)); 10772 10773 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10774 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 10775 type = language_bool_type (exp->language_defn, exp->gdbarch); 10776 return 10777 value_from_longest (type, 10778 (value_less (arg1, arg3) 10779 || value_equal (arg1, arg3)) 10780 && (value_less (arg2, arg1) 10781 || value_equal (arg2, arg1))); 10782 10783 case TERNOP_IN_RANGE: 10784 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10785 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10786 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10787 10788 if (noside == EVAL_SKIP) 10789 goto nosideret; 10790 10791 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10792 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3); 10793 type = language_bool_type (exp->language_defn, exp->gdbarch); 10794 return 10795 value_from_longest (type, 10796 (value_less (arg1, arg3) 10797 || value_equal (arg1, arg3)) 10798 && (value_less (arg2, arg1) 10799 || value_equal (arg2, arg1))); 10800 10801 case OP_ATR_FIRST: 10802 case OP_ATR_LAST: 10803 case OP_ATR_LENGTH: 10804 { 10805 struct type *type_arg; 10806 10807 if (exp->elts[*pos].opcode == OP_TYPE) 10808 { 10809 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 10810 arg1 = NULL; 10811 type_arg = check_typedef (exp->elts[pc + 2].type); 10812 } 10813 else 10814 { 10815 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10816 type_arg = NULL; 10817 } 10818 10819 if (exp->elts[*pos].opcode != OP_LONG) 10820 error (_("Invalid operand to '%s"), ada_attribute_name (op)); 10821 tem = longest_to_int (exp->elts[*pos + 2].longconst); 10822 *pos += 4; 10823 10824 if (noside == EVAL_SKIP) 10825 goto nosideret; 10826 10827 if (type_arg == NULL) 10828 { 10829 arg1 = ada_coerce_ref (arg1); 10830 10831 if (ada_is_constrained_packed_array_type (value_type (arg1))) 10832 arg1 = ada_coerce_to_simple_array (arg1); 10833 10834 if (op == OP_ATR_LENGTH) 10835 type = builtin_type (exp->gdbarch)->builtin_int; 10836 else 10837 { 10838 type = ada_index_type (value_type (arg1), tem, 10839 ada_attribute_name (op)); 10840 if (type == NULL) 10841 type = builtin_type (exp->gdbarch)->builtin_int; 10842 } 10843 10844 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10845 return allocate_value (type); 10846 10847 switch (op) 10848 { 10849 default: /* Should never happen. */ 10850 error (_("unexpected attribute encountered")); 10851 case OP_ATR_FIRST: 10852 return value_from_longest 10853 (type, ada_array_bound (arg1, tem, 0)); 10854 case OP_ATR_LAST: 10855 return value_from_longest 10856 (type, ada_array_bound (arg1, tem, 1)); 10857 case OP_ATR_LENGTH: 10858 return value_from_longest 10859 (type, ada_array_length (arg1, tem)); 10860 } 10861 } 10862 else if (discrete_type_p (type_arg)) 10863 { 10864 struct type *range_type; 10865 const char *name = ada_type_name (type_arg); 10866 10867 range_type = NULL; 10868 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM) 10869 range_type = to_fixed_range_type (type_arg, NULL); 10870 if (range_type == NULL) 10871 range_type = type_arg; 10872 switch (op) 10873 { 10874 default: 10875 error (_("unexpected attribute encountered")); 10876 case OP_ATR_FIRST: 10877 return value_from_longest 10878 (range_type, ada_discrete_type_low_bound (range_type)); 10879 case OP_ATR_LAST: 10880 return value_from_longest 10881 (range_type, ada_discrete_type_high_bound (range_type)); 10882 case OP_ATR_LENGTH: 10883 error (_("the 'length attribute applies only to array types")); 10884 } 10885 } 10886 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT) 10887 error (_("unimplemented type attribute")); 10888 else 10889 { 10890 LONGEST low, high; 10891 10892 if (ada_is_constrained_packed_array_type (type_arg)) 10893 type_arg = decode_constrained_packed_array_type (type_arg); 10894 10895 if (op == OP_ATR_LENGTH) 10896 type = builtin_type (exp->gdbarch)->builtin_int; 10897 else 10898 { 10899 type = ada_index_type (type_arg, tem, ada_attribute_name (op)); 10900 if (type == NULL) 10901 type = builtin_type (exp->gdbarch)->builtin_int; 10902 } 10903 10904 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10905 return allocate_value (type); 10906 10907 switch (op) 10908 { 10909 default: 10910 error (_("unexpected attribute encountered")); 10911 case OP_ATR_FIRST: 10912 low = ada_array_bound_from_type (type_arg, tem, 0); 10913 return value_from_longest (type, low); 10914 case OP_ATR_LAST: 10915 high = ada_array_bound_from_type (type_arg, tem, 1); 10916 return value_from_longest (type, high); 10917 case OP_ATR_LENGTH: 10918 low = ada_array_bound_from_type (type_arg, tem, 0); 10919 high = ada_array_bound_from_type (type_arg, tem, 1); 10920 return value_from_longest (type, high - low + 1); 10921 } 10922 } 10923 } 10924 10925 case OP_ATR_TAG: 10926 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10927 if (noside == EVAL_SKIP) 10928 goto nosideret; 10929 10930 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10931 return value_zero (ada_tag_type (arg1), not_lval); 10932 10933 return ada_value_tag (arg1); 10934 10935 case OP_ATR_MIN: 10936 case OP_ATR_MAX: 10937 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 10938 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10939 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10940 if (noside == EVAL_SKIP) 10941 goto nosideret; 10942 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 10943 return value_zero (value_type (arg1), not_lval); 10944 else 10945 { 10946 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 10947 return value_binop (arg1, arg2, 10948 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX); 10949 } 10950 10951 case OP_ATR_MODULUS: 10952 { 10953 struct type *type_arg = check_typedef (exp->elts[pc + 2].type); 10954 10955 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 10956 if (noside == EVAL_SKIP) 10957 goto nosideret; 10958 10959 if (!ada_is_modular_type (type_arg)) 10960 error (_("'modulus must be applied to modular type")); 10961 10962 return value_from_longest (TYPE_TARGET_TYPE (type_arg), 10963 ada_modulus (type_arg)); 10964 } 10965 10966 10967 case OP_ATR_POS: 10968 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 10969 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10970 if (noside == EVAL_SKIP) 10971 goto nosideret; 10972 type = builtin_type (exp->gdbarch)->builtin_int; 10973 if (noside == EVAL_AVOID_SIDE_EFFECTS) 10974 return value_zero (type, not_lval); 10975 else 10976 return value_pos_atr (type, arg1); 10977 10978 case OP_ATR_SIZE: 10979 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10980 type = value_type (arg1); 10981 10982 /* If the argument is a reference, then dereference its type, since 10983 the user is really asking for the size of the actual object, 10984 not the size of the pointer. */ 10985 if (TYPE_CODE (type) == TYPE_CODE_REF) 10986 type = TYPE_TARGET_TYPE (type); 10987 10988 if (noside == EVAL_SKIP) 10989 goto nosideret; 10990 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 10991 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval); 10992 else 10993 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 10994 TARGET_CHAR_BIT * TYPE_LENGTH (type)); 10995 10996 case OP_ATR_VAL: 10997 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP); 10998 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 10999 type = exp->elts[pc + 2].type; 11000 if (noside == EVAL_SKIP) 11001 goto nosideret; 11002 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11003 return value_zero (type, not_lval); 11004 else 11005 return value_val_atr (type, arg1); 11006 11007 case BINOP_EXP: 11008 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11009 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11010 if (noside == EVAL_SKIP) 11011 goto nosideret; 11012 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11013 return value_zero (value_type (arg1), not_lval); 11014 else 11015 { 11016 /* For integer exponentiation operations, 11017 only promote the first argument. */ 11018 if (is_integral_type (value_type (arg2))) 11019 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 11020 else 11021 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2); 11022 11023 return value_binop (arg1, arg2, op); 11024 } 11025 11026 case UNOP_PLUS: 11027 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11028 if (noside == EVAL_SKIP) 11029 goto nosideret; 11030 else 11031 return arg1; 11032 11033 case UNOP_ABS: 11034 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11035 if (noside == EVAL_SKIP) 11036 goto nosideret; 11037 unop_promote (exp->language_defn, exp->gdbarch, &arg1); 11038 if (value_less (arg1, value_zero (value_type (arg1), not_lval))) 11039 return value_neg (arg1); 11040 else 11041 return arg1; 11042 11043 case UNOP_IND: 11044 preeval_pos = *pos; 11045 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11046 if (noside == EVAL_SKIP) 11047 goto nosideret; 11048 type = ada_check_typedef (value_type (arg1)); 11049 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11050 { 11051 if (ada_is_array_descriptor_type (type)) 11052 /* GDB allows dereferencing GNAT array descriptors. */ 11053 { 11054 struct type *arrType = ada_type_of_array (arg1, 0); 11055 11056 if (arrType == NULL) 11057 error (_("Attempt to dereference null array pointer.")); 11058 return value_at_lazy (arrType, 0); 11059 } 11060 else if (TYPE_CODE (type) == TYPE_CODE_PTR 11061 || TYPE_CODE (type) == TYPE_CODE_REF 11062 /* In C you can dereference an array to get the 1st elt. */ 11063 || TYPE_CODE (type) == TYPE_CODE_ARRAY) 11064 { 11065 /* As mentioned in the OP_VAR_VALUE case, tagged types can 11066 only be determined by inspecting the object's tag. 11067 This means that we need to evaluate completely the 11068 expression in order to get its type. */ 11069 11070 if ((TYPE_CODE (type) == TYPE_CODE_REF 11071 || TYPE_CODE (type) == TYPE_CODE_PTR) 11072 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)) 11073 { 11074 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos, 11075 EVAL_NORMAL); 11076 type = value_type (ada_value_ind (arg1)); 11077 } 11078 else 11079 { 11080 type = to_static_fixed_type 11081 (ada_aligned_type 11082 (ada_check_typedef (TYPE_TARGET_TYPE (type)))); 11083 } 11084 ada_ensure_varsize_limit (type); 11085 return value_zero (type, lval_memory); 11086 } 11087 else if (TYPE_CODE (type) == TYPE_CODE_INT) 11088 { 11089 /* GDB allows dereferencing an int. */ 11090 if (expect_type == NULL) 11091 return value_zero (builtin_type (exp->gdbarch)->builtin_int, 11092 lval_memory); 11093 else 11094 { 11095 expect_type = 11096 to_static_fixed_type (ada_aligned_type (expect_type)); 11097 return value_zero (expect_type, lval_memory); 11098 } 11099 } 11100 else 11101 error (_("Attempt to take contents of a non-pointer value.")); 11102 } 11103 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */ 11104 type = ada_check_typedef (value_type (arg1)); 11105 11106 if (TYPE_CODE (type) == TYPE_CODE_INT) 11107 /* GDB allows dereferencing an int. If we were given 11108 the expect_type, then use that as the target type. 11109 Otherwise, assume that the target type is an int. */ 11110 { 11111 if (expect_type != NULL) 11112 return ada_value_ind (value_cast (lookup_pointer_type (expect_type), 11113 arg1)); 11114 else 11115 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int, 11116 (CORE_ADDR) value_as_address (arg1)); 11117 } 11118 11119 if (ada_is_array_descriptor_type (type)) 11120 /* GDB allows dereferencing GNAT array descriptors. */ 11121 return ada_coerce_to_simple_array (arg1); 11122 else 11123 return ada_value_ind (arg1); 11124 11125 case STRUCTOP_STRUCT: 11126 tem = longest_to_int (exp->elts[pc + 1].longconst); 11127 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1); 11128 preeval_pos = *pos; 11129 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); 11130 if (noside == EVAL_SKIP) 11131 goto nosideret; 11132 if (noside == EVAL_AVOID_SIDE_EFFECTS) 11133 { 11134 struct type *type1 = value_type (arg1); 11135 11136 if (ada_is_tagged_type (type1, 1)) 11137 { 11138 type = ada_lookup_struct_elt_type (type1, 11139 &exp->elts[pc + 2].string, 11140 1, 1, NULL); 11141 11142 /* If the field is not found, check if it exists in the 11143 extension of this object's type. This means that we 11144 need to evaluate completely the expression. */ 11145 11146 if (type == NULL) 11147 { 11148 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos, 11149 EVAL_NORMAL); 11150 arg1 = ada_value_struct_elt (arg1, 11151 &exp->elts[pc + 2].string, 11152 0); 11153 arg1 = unwrap_value (arg1); 11154 type = value_type (ada_to_fixed_value (arg1)); 11155 } 11156 } 11157 else 11158 type = 11159 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1, 11160 0, NULL); 11161 11162 return value_zero (ada_aligned_type (type), lval_memory); 11163 } 11164 else 11165 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0); 11166 arg1 = unwrap_value (arg1); 11167 return ada_to_fixed_value (arg1); 11168 11169 case OP_TYPE: 11170 /* The value is not supposed to be used. This is here to make it 11171 easier to accommodate expressions that contain types. */ 11172 (*pos) += 2; 11173 if (noside == EVAL_SKIP) 11174 goto nosideret; 11175 else if (noside == EVAL_AVOID_SIDE_EFFECTS) 11176 return allocate_value (exp->elts[pc + 1].type); 11177 else 11178 error (_("Attempt to use a type name as an expression")); 11179 11180 case OP_AGGREGATE: 11181 case OP_CHOICES: 11182 case OP_OTHERS: 11183 case OP_DISCRETE_RANGE: 11184 case OP_POSITIONAL: 11185 case OP_NAME: 11186 if (noside == EVAL_NORMAL) 11187 switch (op) 11188 { 11189 case OP_NAME: 11190 error (_("Undefined name, ambiguous name, or renaming used in " 11191 "component association: %s."), &exp->elts[pc+2].string); 11192 case OP_AGGREGATE: 11193 error (_("Aggregates only allowed on the right of an assignment")); 11194 default: 11195 internal_error (__FILE__, __LINE__, 11196 _("aggregate apparently mangled")); 11197 } 11198 11199 ada_forward_operator_length (exp, pc, &oplen, &nargs); 11200 *pos += oplen - 1; 11201 for (tem = 0; tem < nargs; tem += 1) 11202 ada_evaluate_subexp (NULL, exp, pos, noside); 11203 goto nosideret; 11204 } 11205 11206nosideret: 11207 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1); 11208} 11209 11210 11211 /* Fixed point */ 11212 11213/* If TYPE encodes an Ada fixed-point type, return the suffix of the 11214 type name that encodes the 'small and 'delta information. 11215 Otherwise, return NULL. */ 11216 11217static const char * 11218fixed_type_info (struct type *type) 11219{ 11220 const char *name = ada_type_name (type); 11221 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type); 11222 11223 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL) 11224 { 11225 const char *tail = strstr (name, "___XF_"); 11226 11227 if (tail == NULL) 11228 return NULL; 11229 else 11230 return tail + 5; 11231 } 11232 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type) 11233 return fixed_type_info (TYPE_TARGET_TYPE (type)); 11234 else 11235 return NULL; 11236} 11237 11238/* Returns non-zero iff TYPE represents an Ada fixed-point type. */ 11239 11240int 11241ada_is_fixed_point_type (struct type *type) 11242{ 11243 return fixed_type_info (type) != NULL; 11244} 11245 11246/* Return non-zero iff TYPE represents a System.Address type. */ 11247 11248int 11249ada_is_system_address_type (struct type *type) 11250{ 11251 return (TYPE_NAME (type) 11252 && strcmp (TYPE_NAME (type), "system__address") == 0); 11253} 11254 11255/* Assuming that TYPE is the representation of an Ada fixed-point 11256 type, return its delta, or -1 if the type is malformed and the 11257 delta cannot be determined. */ 11258 11259DOUBLEST 11260ada_delta (struct type *type) 11261{ 11262 const char *encoding = fixed_type_info (type); 11263 DOUBLEST num, den; 11264 11265 /* Strictly speaking, num and den are encoded as integer. However, 11266 they may not fit into a long, and they will have to be converted 11267 to DOUBLEST anyway. So scan them as DOUBLEST. */ 11268 if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT, 11269 &num, &den) < 2) 11270 return -1.0; 11271 else 11272 return num / den; 11273} 11274 11275/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling 11276 factor ('SMALL value) associated with the type. */ 11277 11278static DOUBLEST 11279scaling_factor (struct type *type) 11280{ 11281 const char *encoding = fixed_type_info (type); 11282 DOUBLEST num0, den0, num1, den1; 11283 int n; 11284 11285 /* Strictly speaking, num's and den's are encoded as integer. However, 11286 they may not fit into a long, and they will have to be converted 11287 to DOUBLEST anyway. So scan them as DOUBLEST. */ 11288 n = sscanf (encoding, 11289 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT 11290 "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT, 11291 &num0, &den0, &num1, &den1); 11292 11293 if (n < 2) 11294 return 1.0; 11295 else if (n == 4) 11296 return num1 / den1; 11297 else 11298 return num0 / den0; 11299} 11300 11301 11302/* Assuming that X is the representation of a value of fixed-point 11303 type TYPE, return its floating-point equivalent. */ 11304 11305DOUBLEST 11306ada_fixed_to_float (struct type *type, LONGEST x) 11307{ 11308 return (DOUBLEST) x *scaling_factor (type); 11309} 11310 11311/* The representation of a fixed-point value of type TYPE 11312 corresponding to the value X. */ 11313 11314LONGEST 11315ada_float_to_fixed (struct type *type, DOUBLEST x) 11316{ 11317 return (LONGEST) (x / scaling_factor (type) + 0.5); 11318} 11319 11320 11321 11322 /* Range types */ 11323 11324/* Scan STR beginning at position K for a discriminant name, and 11325 return the value of that discriminant field of DVAL in *PX. If 11326 PNEW_K is not null, put the position of the character beyond the 11327 name scanned in *PNEW_K. Return 1 if successful; return 0 and do 11328 not alter *PX and *PNEW_K if unsuccessful. */ 11329 11330static int 11331scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px, 11332 int *pnew_k) 11333{ 11334 static char *bound_buffer = NULL; 11335 static size_t bound_buffer_len = 0; 11336 char *bound; 11337 char *pend; 11338 struct value *bound_val; 11339 11340 if (dval == NULL || str == NULL || str[k] == '\0') 11341 return 0; 11342 11343 pend = strstr (str + k, "__"); 11344 if (pend == NULL) 11345 { 11346 bound = str + k; 11347 k += strlen (bound); 11348 } 11349 else 11350 { 11351 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1); 11352 bound = bound_buffer; 11353 strncpy (bound_buffer, str + k, pend - (str + k)); 11354 bound[pend - (str + k)] = '\0'; 11355 k = pend - str; 11356 } 11357 11358 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval)); 11359 if (bound_val == NULL) 11360 return 0; 11361 11362 *px = value_as_long (bound_val); 11363 if (pnew_k != NULL) 11364 *pnew_k = k; 11365 return 1; 11366} 11367 11368/* Value of variable named NAME in the current environment. If 11369 no such variable found, then if ERR_MSG is null, returns 0, and 11370 otherwise causes an error with message ERR_MSG. */ 11371 11372static struct value * 11373get_var_value (char *name, char *err_msg) 11374{ 11375 struct ada_symbol_info *syms; 11376 int nsyms; 11377 11378 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN, 11379 &syms); 11380 11381 if (nsyms != 1) 11382 { 11383 if (err_msg == NULL) 11384 return 0; 11385 else 11386 error (("%s"), err_msg); 11387 } 11388 11389 return value_of_variable (syms[0].sym, syms[0].block); 11390} 11391 11392/* Value of integer variable named NAME in the current environment. If 11393 no such variable found, returns 0, and sets *FLAG to 0. If 11394 successful, sets *FLAG to 1. */ 11395 11396LONGEST 11397get_int_var_value (char *name, int *flag) 11398{ 11399 struct value *var_val = get_var_value (name, 0); 11400 11401 if (var_val == 0) 11402 { 11403 if (flag != NULL) 11404 *flag = 0; 11405 return 0; 11406 } 11407 else 11408 { 11409 if (flag != NULL) 11410 *flag = 1; 11411 return value_as_long (var_val); 11412 } 11413} 11414 11415 11416/* Return a range type whose base type is that of the range type named 11417 NAME in the current environment, and whose bounds are calculated 11418 from NAME according to the GNAT range encoding conventions. 11419 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the 11420 corresponding range type from debug information; fall back to using it 11421 if symbol lookup fails. If a new type must be created, allocate it 11422 like ORIG_TYPE was. The bounds information, in general, is encoded 11423 in NAME, the base type given in the named range type. */ 11424 11425static struct type * 11426to_fixed_range_type (struct type *raw_type, struct value *dval) 11427{ 11428 const char *name; 11429 struct type *base_type; 11430 char *subtype_info; 11431 11432 gdb_assert (raw_type != NULL); 11433 gdb_assert (TYPE_NAME (raw_type) != NULL); 11434 11435 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE) 11436 base_type = TYPE_TARGET_TYPE (raw_type); 11437 else 11438 base_type = raw_type; 11439 11440 name = TYPE_NAME (raw_type); 11441 subtype_info = strstr (name, "___XD"); 11442 if (subtype_info == NULL) 11443 { 11444 LONGEST L = ada_discrete_type_low_bound (raw_type); 11445 LONGEST U = ada_discrete_type_high_bound (raw_type); 11446 11447 if (L < INT_MIN || U > INT_MAX) 11448 return raw_type; 11449 else 11450 return create_static_range_type (alloc_type_copy (raw_type), raw_type, 11451 L, U); 11452 } 11453 else 11454 { 11455 static char *name_buf = NULL; 11456 static size_t name_len = 0; 11457 int prefix_len = subtype_info - name; 11458 LONGEST L, U; 11459 struct type *type; 11460 char *bounds_str; 11461 int n; 11462 11463 GROW_VECT (name_buf, name_len, prefix_len + 5); 11464 strncpy (name_buf, name, prefix_len); 11465 name_buf[prefix_len] = '\0'; 11466 11467 subtype_info += 5; 11468 bounds_str = strchr (subtype_info, '_'); 11469 n = 1; 11470 11471 if (*subtype_info == 'L') 11472 { 11473 if (!ada_scan_number (bounds_str, n, &L, &n) 11474 && !scan_discrim_bound (bounds_str, n, dval, &L, &n)) 11475 return raw_type; 11476 if (bounds_str[n] == '_') 11477 n += 2; 11478 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */ 11479 n += 1; 11480 subtype_info += 1; 11481 } 11482 else 11483 { 11484 int ok; 11485 11486 strcpy (name_buf + prefix_len, "___L"); 11487 L = get_int_var_value (name_buf, &ok); 11488 if (!ok) 11489 { 11490 lim_warning (_("Unknown lower bound, using 1.")); 11491 L = 1; 11492 } 11493 } 11494 11495 if (*subtype_info == 'U') 11496 { 11497 if (!ada_scan_number (bounds_str, n, &U, &n) 11498 && !scan_discrim_bound (bounds_str, n, dval, &U, &n)) 11499 return raw_type; 11500 } 11501 else 11502 { 11503 int ok; 11504 11505 strcpy (name_buf + prefix_len, "___U"); 11506 U = get_int_var_value (name_buf, &ok); 11507 if (!ok) 11508 { 11509 lim_warning (_("Unknown upper bound, using %ld."), (long) L); 11510 U = L; 11511 } 11512 } 11513 11514 type = create_static_range_type (alloc_type_copy (raw_type), 11515 base_type, L, U); 11516 TYPE_NAME (type) = name; 11517 return type; 11518 } 11519} 11520 11521/* True iff NAME is the name of a range type. */ 11522 11523int 11524ada_is_range_type_name (const char *name) 11525{ 11526 return (name != NULL && strstr (name, "___XD")); 11527} 11528 11529 11530 /* Modular types */ 11531 11532/* True iff TYPE is an Ada modular type. */ 11533 11534int 11535ada_is_modular_type (struct type *type) 11536{ 11537 struct type *subranged_type = get_base_type (type); 11538 11539 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE 11540 && TYPE_CODE (subranged_type) == TYPE_CODE_INT 11541 && TYPE_UNSIGNED (subranged_type)); 11542} 11543 11544/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */ 11545 11546ULONGEST 11547ada_modulus (struct type *type) 11548{ 11549 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1; 11550} 11551 11552 11553/* Ada exception catchpoint support: 11554 --------------------------------- 11555 11556 We support 3 kinds of exception catchpoints: 11557 . catchpoints on Ada exceptions 11558 . catchpoints on unhandled Ada exceptions 11559 . catchpoints on failed assertions 11560 11561 Exceptions raised during failed assertions, or unhandled exceptions 11562 could perfectly be caught with the general catchpoint on Ada exceptions. 11563 However, we can easily differentiate these two special cases, and having 11564 the option to distinguish these two cases from the rest can be useful 11565 to zero-in on certain situations. 11566 11567 Exception catchpoints are a specialized form of breakpoint, 11568 since they rely on inserting breakpoints inside known routines 11569 of the GNAT runtime. The implementation therefore uses a standard 11570 breakpoint structure of the BP_BREAKPOINT type, but with its own set 11571 of breakpoint_ops. 11572 11573 Support in the runtime for exception catchpoints have been changed 11574 a few times already, and these changes affect the implementation 11575 of these catchpoints. In order to be able to support several 11576 variants of the runtime, we use a sniffer that will determine 11577 the runtime variant used by the program being debugged. */ 11578 11579/* Ada's standard exceptions. 11580 11581 The Ada 83 standard also defined Numeric_Error. But there so many 11582 situations where it was unclear from the Ada 83 Reference Manual 11583 (RM) whether Constraint_Error or Numeric_Error should be raised, 11584 that the ARG (Ada Rapporteur Group) eventually issued a Binding 11585 Interpretation saying that anytime the RM says that Numeric_Error 11586 should be raised, the implementation may raise Constraint_Error. 11587 Ada 95 went one step further and pretty much removed Numeric_Error 11588 from the list of standard exceptions (it made it a renaming of 11589 Constraint_Error, to help preserve compatibility when compiling 11590 an Ada83 compiler). As such, we do not include Numeric_Error from 11591 this list of standard exceptions. */ 11592 11593static char *standard_exc[] = { 11594 "constraint_error", 11595 "program_error", 11596 "storage_error", 11597 "tasking_error" 11598}; 11599 11600typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void); 11601 11602/* A structure that describes how to support exception catchpoints 11603 for a given executable. */ 11604 11605struct exception_support_info 11606{ 11607 /* The name of the symbol to break on in order to insert 11608 a catchpoint on exceptions. */ 11609 const char *catch_exception_sym; 11610 11611 /* The name of the symbol to break on in order to insert 11612 a catchpoint on unhandled exceptions. */ 11613 const char *catch_exception_unhandled_sym; 11614 11615 /* The name of the symbol to break on in order to insert 11616 a catchpoint on failed assertions. */ 11617 const char *catch_assert_sym; 11618 11619 /* Assuming that the inferior just triggered an unhandled exception 11620 catchpoint, this function is responsible for returning the address 11621 in inferior memory where the name of that exception is stored. 11622 Return zero if the address could not be computed. */ 11623 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr; 11624}; 11625 11626static CORE_ADDR ada_unhandled_exception_name_addr (void); 11627static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void); 11628 11629/* The following exception support info structure describes how to 11630 implement exception catchpoints with the latest version of the 11631 Ada runtime (as of 2007-03-06). */ 11632 11633static const struct exception_support_info default_exception_support_info = 11634{ 11635 "__gnat_debug_raise_exception", /* catch_exception_sym */ 11636 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */ 11637 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */ 11638 ada_unhandled_exception_name_addr 11639}; 11640 11641/* The following exception support info structure describes how to 11642 implement exception catchpoints with a slightly older version 11643 of the Ada runtime. */ 11644 11645static const struct exception_support_info exception_support_info_fallback = 11646{ 11647 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */ 11648 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */ 11649 "system__assertions__raise_assert_failure", /* catch_assert_sym */ 11650 ada_unhandled_exception_name_addr_from_raise 11651}; 11652 11653/* Return nonzero if we can detect the exception support routines 11654 described in EINFO. 11655 11656 This function errors out if an abnormal situation is detected 11657 (for instance, if we find the exception support routines, but 11658 that support is found to be incomplete). */ 11659 11660static int 11661ada_has_this_exception_support (const struct exception_support_info *einfo) 11662{ 11663 struct symbol *sym; 11664 11665 /* The symbol we're looking up is provided by a unit in the GNAT runtime 11666 that should be compiled with debugging information. As a result, we 11667 expect to find that symbol in the symtabs. */ 11668 11669 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN); 11670 if (sym == NULL) 11671 { 11672 /* Perhaps we did not find our symbol because the Ada runtime was 11673 compiled without debugging info, or simply stripped of it. 11674 It happens on some GNU/Linux distributions for instance, where 11675 users have to install a separate debug package in order to get 11676 the runtime's debugging info. In that situation, let the user 11677 know why we cannot insert an Ada exception catchpoint. 11678 11679 Note: Just for the purpose of inserting our Ada exception 11680 catchpoint, we could rely purely on the associated minimal symbol. 11681 But we would be operating in degraded mode anyway, since we are 11682 still lacking the debugging info needed later on to extract 11683 the name of the exception being raised (this name is printed in 11684 the catchpoint message, and is also used when trying to catch 11685 a specific exception). We do not handle this case for now. */ 11686 struct bound_minimal_symbol msym 11687 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL); 11688 11689 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline) 11690 error (_("Your Ada runtime appears to be missing some debugging " 11691 "information.\nCannot insert Ada exception catchpoint " 11692 "in this configuration.")); 11693 11694 return 0; 11695 } 11696 11697 /* Make sure that the symbol we found corresponds to a function. */ 11698 11699 if (SYMBOL_CLASS (sym) != LOC_BLOCK) 11700 error (_("Symbol \"%s\" is not a function (class = %d)"), 11701 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym)); 11702 11703 return 1; 11704} 11705 11706/* Inspect the Ada runtime and determine which exception info structure 11707 should be used to provide support for exception catchpoints. 11708 11709 This function will always set the per-inferior exception_info, 11710 or raise an error. */ 11711 11712static void 11713ada_exception_support_info_sniffer (void) 11714{ 11715 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 11716 11717 /* If the exception info is already known, then no need to recompute it. */ 11718 if (data->exception_info != NULL) 11719 return; 11720 11721 /* Check the latest (default) exception support info. */ 11722 if (ada_has_this_exception_support (&default_exception_support_info)) 11723 { 11724 data->exception_info = &default_exception_support_info; 11725 return; 11726 } 11727 11728 /* Try our fallback exception suport info. */ 11729 if (ada_has_this_exception_support (&exception_support_info_fallback)) 11730 { 11731 data->exception_info = &exception_support_info_fallback; 11732 return; 11733 } 11734 11735 /* Sometimes, it is normal for us to not be able to find the routine 11736 we are looking for. This happens when the program is linked with 11737 the shared version of the GNAT runtime, and the program has not been 11738 started yet. Inform the user of these two possible causes if 11739 applicable. */ 11740 11741 if (ada_update_initial_language (language_unknown) != language_ada) 11742 error (_("Unable to insert catchpoint. Is this an Ada main program?")); 11743 11744 /* If the symbol does not exist, then check that the program is 11745 already started, to make sure that shared libraries have been 11746 loaded. If it is not started, this may mean that the symbol is 11747 in a shared library. */ 11748 11749 if (ptid_get_pid (inferior_ptid) == 0) 11750 error (_("Unable to insert catchpoint. Try to start the program first.")); 11751 11752 /* At this point, we know that we are debugging an Ada program and 11753 that the inferior has been started, but we still are not able to 11754 find the run-time symbols. That can mean that we are in 11755 configurable run time mode, or that a-except as been optimized 11756 out by the linker... In any case, at this point it is not worth 11757 supporting this feature. */ 11758 11759 error (_("Cannot insert Ada exception catchpoints in this configuration.")); 11760} 11761 11762/* True iff FRAME is very likely to be that of a function that is 11763 part of the runtime system. This is all very heuristic, but is 11764 intended to be used as advice as to what frames are uninteresting 11765 to most users. */ 11766 11767static int 11768is_known_support_routine (struct frame_info *frame) 11769{ 11770 struct symtab_and_line sal; 11771 char *func_name; 11772 enum language func_lang; 11773 int i; 11774 const char *fullname; 11775 11776 /* If this code does not have any debugging information (no symtab), 11777 This cannot be any user code. */ 11778 11779 find_frame_sal (frame, &sal); 11780 if (sal.symtab == NULL) 11781 return 1; 11782 11783 /* If there is a symtab, but the associated source file cannot be 11784 located, then assume this is not user code: Selecting a frame 11785 for which we cannot display the code would not be very helpful 11786 for the user. This should also take care of case such as VxWorks 11787 where the kernel has some debugging info provided for a few units. */ 11788 11789 fullname = symtab_to_fullname (sal.symtab); 11790 if (access (fullname, R_OK) != 0) 11791 return 1; 11792 11793 /* Check the unit filename againt the Ada runtime file naming. 11794 We also check the name of the objfile against the name of some 11795 known system libraries that sometimes come with debugging info 11796 too. */ 11797 11798 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1) 11799 { 11800 re_comp (known_runtime_file_name_patterns[i]); 11801 if (re_exec (lbasename (sal.symtab->filename))) 11802 return 1; 11803 if (SYMTAB_OBJFILE (sal.symtab) != NULL 11804 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab)))) 11805 return 1; 11806 } 11807 11808 /* Check whether the function is a GNAT-generated entity. */ 11809 11810 find_frame_funname (frame, &func_name, &func_lang, NULL); 11811 if (func_name == NULL) 11812 return 1; 11813 11814 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1) 11815 { 11816 re_comp (known_auxiliary_function_name_patterns[i]); 11817 if (re_exec (func_name)) 11818 { 11819 xfree (func_name); 11820 return 1; 11821 } 11822 } 11823 11824 xfree (func_name); 11825 return 0; 11826} 11827 11828/* Find the first frame that contains debugging information and that is not 11829 part of the Ada run-time, starting from FI and moving upward. */ 11830 11831void 11832ada_find_printable_frame (struct frame_info *fi) 11833{ 11834 for (; fi != NULL; fi = get_prev_frame (fi)) 11835 { 11836 if (!is_known_support_routine (fi)) 11837 { 11838 select_frame (fi); 11839 break; 11840 } 11841 } 11842 11843} 11844 11845/* Assuming that the inferior just triggered an unhandled exception 11846 catchpoint, return the address in inferior memory where the name 11847 of the exception is stored. 11848 11849 Return zero if the address could not be computed. */ 11850 11851static CORE_ADDR 11852ada_unhandled_exception_name_addr (void) 11853{ 11854 return parse_and_eval_address ("e.full_name"); 11855} 11856 11857/* Same as ada_unhandled_exception_name_addr, except that this function 11858 should be used when the inferior uses an older version of the runtime, 11859 where the exception name needs to be extracted from a specific frame 11860 several frames up in the callstack. */ 11861 11862static CORE_ADDR 11863ada_unhandled_exception_name_addr_from_raise (void) 11864{ 11865 int frame_level; 11866 struct frame_info *fi; 11867 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 11868 struct cleanup *old_chain; 11869 11870 /* To determine the name of this exception, we need to select 11871 the frame corresponding to RAISE_SYM_NAME. This frame is 11872 at least 3 levels up, so we simply skip the first 3 frames 11873 without checking the name of their associated function. */ 11874 fi = get_current_frame (); 11875 for (frame_level = 0; frame_level < 3; frame_level += 1) 11876 if (fi != NULL) 11877 fi = get_prev_frame (fi); 11878 11879 old_chain = make_cleanup (null_cleanup, NULL); 11880 while (fi != NULL) 11881 { 11882 char *func_name; 11883 enum language func_lang; 11884 11885 find_frame_funname (fi, &func_name, &func_lang, NULL); 11886 if (func_name != NULL) 11887 { 11888 make_cleanup (xfree, func_name); 11889 11890 if (strcmp (func_name, 11891 data->exception_info->catch_exception_sym) == 0) 11892 break; /* We found the frame we were looking for... */ 11893 fi = get_prev_frame (fi); 11894 } 11895 } 11896 do_cleanups (old_chain); 11897 11898 if (fi == NULL) 11899 return 0; 11900 11901 select_frame (fi); 11902 return parse_and_eval_address ("id.full_name"); 11903} 11904 11905/* Assuming the inferior just triggered an Ada exception catchpoint 11906 (of any type), return the address in inferior memory where the name 11907 of the exception is stored, if applicable. 11908 11909 Return zero if the address could not be computed, or if not relevant. */ 11910 11911static CORE_ADDR 11912ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex, 11913 struct breakpoint *b) 11914{ 11915 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 11916 11917 switch (ex) 11918 { 11919 case ada_catch_exception: 11920 return (parse_and_eval_address ("e.full_name")); 11921 break; 11922 11923 case ada_catch_exception_unhandled: 11924 return data->exception_info->unhandled_exception_name_addr (); 11925 break; 11926 11927 case ada_catch_assert: 11928 return 0; /* Exception name is not relevant in this case. */ 11929 break; 11930 11931 default: 11932 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 11933 break; 11934 } 11935 11936 return 0; /* Should never be reached. */ 11937} 11938 11939/* Same as ada_exception_name_addr_1, except that it intercepts and contains 11940 any error that ada_exception_name_addr_1 might cause to be thrown. 11941 When an error is intercepted, a warning with the error message is printed, 11942 and zero is returned. */ 11943 11944static CORE_ADDR 11945ada_exception_name_addr (enum ada_exception_catchpoint_kind ex, 11946 struct breakpoint *b) 11947{ 11948 CORE_ADDR result = 0; 11949 11950 TRY 11951 { 11952 result = ada_exception_name_addr_1 (ex, b); 11953 } 11954 11955 CATCH (e, RETURN_MASK_ERROR) 11956 { 11957 warning (_("failed to get exception name: %s"), e.message); 11958 return 0; 11959 } 11960 END_CATCH 11961 11962 return result; 11963} 11964 11965static char *ada_exception_catchpoint_cond_string (const char *excep_string); 11966 11967/* Ada catchpoints. 11968 11969 In the case of catchpoints on Ada exceptions, the catchpoint will 11970 stop the target on every exception the program throws. When a user 11971 specifies the name of a specific exception, we translate this 11972 request into a condition expression (in text form), and then parse 11973 it into an expression stored in each of the catchpoint's locations. 11974 We then use this condition to check whether the exception that was 11975 raised is the one the user is interested in. If not, then the 11976 target is resumed again. We store the name of the requested 11977 exception, in order to be able to re-set the condition expression 11978 when symbols change. */ 11979 11980/* An instance of this type is used to represent an Ada catchpoint 11981 breakpoint location. It includes a "struct bp_location" as a kind 11982 of base class; users downcast to "struct bp_location *" when 11983 needed. */ 11984 11985struct ada_catchpoint_location 11986{ 11987 /* The base class. */ 11988 struct bp_location base; 11989 11990 /* The condition that checks whether the exception that was raised 11991 is the specific exception the user specified on catchpoint 11992 creation. */ 11993 struct expression *excep_cond_expr; 11994}; 11995 11996/* Implement the DTOR method in the bp_location_ops structure for all 11997 Ada exception catchpoint kinds. */ 11998 11999static void 12000ada_catchpoint_location_dtor (struct bp_location *bl) 12001{ 12002 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl; 12003 12004 xfree (al->excep_cond_expr); 12005} 12006 12007/* The vtable to be used in Ada catchpoint locations. */ 12008 12009static const struct bp_location_ops ada_catchpoint_location_ops = 12010{ 12011 ada_catchpoint_location_dtor 12012}; 12013 12014/* An instance of this type is used to represent an Ada catchpoint. 12015 It includes a "struct breakpoint" as a kind of base class; users 12016 downcast to "struct breakpoint *" when needed. */ 12017 12018struct ada_catchpoint 12019{ 12020 /* The base class. */ 12021 struct breakpoint base; 12022 12023 /* The name of the specific exception the user specified. */ 12024 char *excep_string; 12025}; 12026 12027/* Parse the exception condition string in the context of each of the 12028 catchpoint's locations, and store them for later evaluation. */ 12029 12030static void 12031create_excep_cond_exprs (struct ada_catchpoint *c) 12032{ 12033 struct cleanup *old_chain; 12034 struct bp_location *bl; 12035 char *cond_string; 12036 12037 /* Nothing to do if there's no specific exception to catch. */ 12038 if (c->excep_string == NULL) 12039 return; 12040 12041 /* Same if there are no locations... */ 12042 if (c->base.loc == NULL) 12043 return; 12044 12045 /* Compute the condition expression in text form, from the specific 12046 expection we want to catch. */ 12047 cond_string = ada_exception_catchpoint_cond_string (c->excep_string); 12048 old_chain = make_cleanup (xfree, cond_string); 12049 12050 /* Iterate over all the catchpoint's locations, and parse an 12051 expression for each. */ 12052 for (bl = c->base.loc; bl != NULL; bl = bl->next) 12053 { 12054 struct ada_catchpoint_location *ada_loc 12055 = (struct ada_catchpoint_location *) bl; 12056 struct expression *exp = NULL; 12057 12058 if (!bl->shlib_disabled) 12059 { 12060 const char *s; 12061 12062 s = cond_string; 12063 TRY 12064 { 12065 exp = parse_exp_1 (&s, bl->address, 12066 block_for_pc (bl->address), 0); 12067 } 12068 CATCH (e, RETURN_MASK_ERROR) 12069 { 12070 warning (_("failed to reevaluate internal exception condition " 12071 "for catchpoint %d: %s"), 12072 c->base.number, e.message); 12073 /* There is a bug in GCC on sparc-solaris when building with 12074 optimization which causes EXP to change unexpectedly 12075 (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982). 12076 The problem should be fixed starting with GCC 4.9. 12077 In the meantime, work around it by forcing EXP back 12078 to NULL. */ 12079 exp = NULL; 12080 } 12081 END_CATCH 12082 } 12083 12084 ada_loc->excep_cond_expr = exp; 12085 } 12086 12087 do_cleanups (old_chain); 12088} 12089 12090/* Implement the DTOR method in the breakpoint_ops structure for all 12091 exception catchpoint kinds. */ 12092 12093static void 12094dtor_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b) 12095{ 12096 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12097 12098 xfree (c->excep_string); 12099 12100 bkpt_breakpoint_ops.dtor (b); 12101} 12102 12103/* Implement the ALLOCATE_LOCATION method in the breakpoint_ops 12104 structure for all exception catchpoint kinds. */ 12105 12106static struct bp_location * 12107allocate_location_exception (enum ada_exception_catchpoint_kind ex, 12108 struct breakpoint *self) 12109{ 12110 struct ada_catchpoint_location *loc; 12111 12112 loc = XNEW (struct ada_catchpoint_location); 12113 init_bp_location (&loc->base, &ada_catchpoint_location_ops, self); 12114 loc->excep_cond_expr = NULL; 12115 return &loc->base; 12116} 12117 12118/* Implement the RE_SET method in the breakpoint_ops structure for all 12119 exception catchpoint kinds. */ 12120 12121static void 12122re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b) 12123{ 12124 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12125 12126 /* Call the base class's method. This updates the catchpoint's 12127 locations. */ 12128 bkpt_breakpoint_ops.re_set (b); 12129 12130 /* Reparse the exception conditional expressions. One for each 12131 location. */ 12132 create_excep_cond_exprs (c); 12133} 12134 12135/* Returns true if we should stop for this breakpoint hit. If the 12136 user specified a specific exception, we only want to cause a stop 12137 if the program thrown that exception. */ 12138 12139static int 12140should_stop_exception (const struct bp_location *bl) 12141{ 12142 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner; 12143 const struct ada_catchpoint_location *ada_loc 12144 = (const struct ada_catchpoint_location *) bl; 12145 int stop; 12146 12147 /* With no specific exception, should always stop. */ 12148 if (c->excep_string == NULL) 12149 return 1; 12150 12151 if (ada_loc->excep_cond_expr == NULL) 12152 { 12153 /* We will have a NULL expression if back when we were creating 12154 the expressions, this location's had failed to parse. */ 12155 return 1; 12156 } 12157 12158 stop = 1; 12159 TRY 12160 { 12161 struct value *mark; 12162 12163 mark = value_mark (); 12164 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr)); 12165 value_free_to_mark (mark); 12166 } 12167 CATCH (ex, RETURN_MASK_ALL) 12168 { 12169 exception_fprintf (gdb_stderr, ex, 12170 _("Error in testing exception condition:\n")); 12171 } 12172 END_CATCH 12173 12174 return stop; 12175} 12176 12177/* Implement the CHECK_STATUS method in the breakpoint_ops structure 12178 for all exception catchpoint kinds. */ 12179 12180static void 12181check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs) 12182{ 12183 bs->stop = should_stop_exception (bs->bp_location_at); 12184} 12185 12186/* Implement the PRINT_IT method in the breakpoint_ops structure 12187 for all exception catchpoint kinds. */ 12188 12189static enum print_stop_action 12190print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs) 12191{ 12192 struct ui_out *uiout = current_uiout; 12193 struct breakpoint *b = bs->breakpoint_at; 12194 12195 annotate_catchpoint (b->number); 12196 12197 if (ui_out_is_mi_like_p (uiout)) 12198 { 12199 ui_out_field_string (uiout, "reason", 12200 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT)); 12201 ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition)); 12202 } 12203 12204 ui_out_text (uiout, 12205 b->disposition == disp_del ? "\nTemporary catchpoint " 12206 : "\nCatchpoint "); 12207 ui_out_field_int (uiout, "bkptno", b->number); 12208 ui_out_text (uiout, ", "); 12209 12210 switch (ex) 12211 { 12212 case ada_catch_exception: 12213 case ada_catch_exception_unhandled: 12214 { 12215 const CORE_ADDR addr = ada_exception_name_addr (ex, b); 12216 char exception_name[256]; 12217 12218 if (addr != 0) 12219 { 12220 read_memory (addr, (gdb_byte *) exception_name, 12221 sizeof (exception_name) - 1); 12222 exception_name [sizeof (exception_name) - 1] = '\0'; 12223 } 12224 else 12225 { 12226 /* For some reason, we were unable to read the exception 12227 name. This could happen if the Runtime was compiled 12228 without debugging info, for instance. In that case, 12229 just replace the exception name by the generic string 12230 "exception" - it will read as "an exception" in the 12231 notification we are about to print. */ 12232 memcpy (exception_name, "exception", sizeof ("exception")); 12233 } 12234 /* In the case of unhandled exception breakpoints, we print 12235 the exception name as "unhandled EXCEPTION_NAME", to make 12236 it clearer to the user which kind of catchpoint just got 12237 hit. We used ui_out_text to make sure that this extra 12238 info does not pollute the exception name in the MI case. */ 12239 if (ex == ada_catch_exception_unhandled) 12240 ui_out_text (uiout, "unhandled "); 12241 ui_out_field_string (uiout, "exception-name", exception_name); 12242 } 12243 break; 12244 case ada_catch_assert: 12245 /* In this case, the name of the exception is not really 12246 important. Just print "failed assertion" to make it clearer 12247 that his program just hit an assertion-failure catchpoint. 12248 We used ui_out_text because this info does not belong in 12249 the MI output. */ 12250 ui_out_text (uiout, "failed assertion"); 12251 break; 12252 } 12253 ui_out_text (uiout, " at "); 12254 ada_find_printable_frame (get_current_frame ()); 12255 12256 return PRINT_SRC_AND_LOC; 12257} 12258 12259/* Implement the PRINT_ONE method in the breakpoint_ops structure 12260 for all exception catchpoint kinds. */ 12261 12262static void 12263print_one_exception (enum ada_exception_catchpoint_kind ex, 12264 struct breakpoint *b, struct bp_location **last_loc) 12265{ 12266 struct ui_out *uiout = current_uiout; 12267 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12268 struct value_print_options opts; 12269 12270 get_user_print_options (&opts); 12271 if (opts.addressprint) 12272 { 12273 annotate_field (4); 12274 ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address); 12275 } 12276 12277 annotate_field (5); 12278 *last_loc = b->loc; 12279 switch (ex) 12280 { 12281 case ada_catch_exception: 12282 if (c->excep_string != NULL) 12283 { 12284 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string); 12285 12286 ui_out_field_string (uiout, "what", msg); 12287 xfree (msg); 12288 } 12289 else 12290 ui_out_field_string (uiout, "what", "all Ada exceptions"); 12291 12292 break; 12293 12294 case ada_catch_exception_unhandled: 12295 ui_out_field_string (uiout, "what", "unhandled Ada exceptions"); 12296 break; 12297 12298 case ada_catch_assert: 12299 ui_out_field_string (uiout, "what", "failed Ada assertions"); 12300 break; 12301 12302 default: 12303 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 12304 break; 12305 } 12306} 12307 12308/* Implement the PRINT_MENTION method in the breakpoint_ops structure 12309 for all exception catchpoint kinds. */ 12310 12311static void 12312print_mention_exception (enum ada_exception_catchpoint_kind ex, 12313 struct breakpoint *b) 12314{ 12315 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12316 struct ui_out *uiout = current_uiout; 12317 12318 ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ") 12319 : _("Catchpoint ")); 12320 ui_out_field_int (uiout, "bkptno", b->number); 12321 ui_out_text (uiout, ": "); 12322 12323 switch (ex) 12324 { 12325 case ada_catch_exception: 12326 if (c->excep_string != NULL) 12327 { 12328 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string); 12329 struct cleanup *old_chain = make_cleanup (xfree, info); 12330 12331 ui_out_text (uiout, info); 12332 do_cleanups (old_chain); 12333 } 12334 else 12335 ui_out_text (uiout, _("all Ada exceptions")); 12336 break; 12337 12338 case ada_catch_exception_unhandled: 12339 ui_out_text (uiout, _("unhandled Ada exceptions")); 12340 break; 12341 12342 case ada_catch_assert: 12343 ui_out_text (uiout, _("failed Ada assertions")); 12344 break; 12345 12346 default: 12347 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 12348 break; 12349 } 12350} 12351 12352/* Implement the PRINT_RECREATE method in the breakpoint_ops structure 12353 for all exception catchpoint kinds. */ 12354 12355static void 12356print_recreate_exception (enum ada_exception_catchpoint_kind ex, 12357 struct breakpoint *b, struct ui_file *fp) 12358{ 12359 struct ada_catchpoint *c = (struct ada_catchpoint *) b; 12360 12361 switch (ex) 12362 { 12363 case ada_catch_exception: 12364 fprintf_filtered (fp, "catch exception"); 12365 if (c->excep_string != NULL) 12366 fprintf_filtered (fp, " %s", c->excep_string); 12367 break; 12368 12369 case ada_catch_exception_unhandled: 12370 fprintf_filtered (fp, "catch exception unhandled"); 12371 break; 12372 12373 case ada_catch_assert: 12374 fprintf_filtered (fp, "catch assert"); 12375 break; 12376 12377 default: 12378 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type")); 12379 } 12380 print_recreate_thread (b, fp); 12381} 12382 12383/* Virtual table for "catch exception" breakpoints. */ 12384 12385static void 12386dtor_catch_exception (struct breakpoint *b) 12387{ 12388 dtor_exception (ada_catch_exception, b); 12389} 12390 12391static struct bp_location * 12392allocate_location_catch_exception (struct breakpoint *self) 12393{ 12394 return allocate_location_exception (ada_catch_exception, self); 12395} 12396 12397static void 12398re_set_catch_exception (struct breakpoint *b) 12399{ 12400 re_set_exception (ada_catch_exception, b); 12401} 12402 12403static void 12404check_status_catch_exception (bpstat bs) 12405{ 12406 check_status_exception (ada_catch_exception, bs); 12407} 12408 12409static enum print_stop_action 12410print_it_catch_exception (bpstat bs) 12411{ 12412 return print_it_exception (ada_catch_exception, bs); 12413} 12414 12415static void 12416print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc) 12417{ 12418 print_one_exception (ada_catch_exception, b, last_loc); 12419} 12420 12421static void 12422print_mention_catch_exception (struct breakpoint *b) 12423{ 12424 print_mention_exception (ada_catch_exception, b); 12425} 12426 12427static void 12428print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp) 12429{ 12430 print_recreate_exception (ada_catch_exception, b, fp); 12431} 12432 12433static struct breakpoint_ops catch_exception_breakpoint_ops; 12434 12435/* Virtual table for "catch exception unhandled" breakpoints. */ 12436 12437static void 12438dtor_catch_exception_unhandled (struct breakpoint *b) 12439{ 12440 dtor_exception (ada_catch_exception_unhandled, b); 12441} 12442 12443static struct bp_location * 12444allocate_location_catch_exception_unhandled (struct breakpoint *self) 12445{ 12446 return allocate_location_exception (ada_catch_exception_unhandled, self); 12447} 12448 12449static void 12450re_set_catch_exception_unhandled (struct breakpoint *b) 12451{ 12452 re_set_exception (ada_catch_exception_unhandled, b); 12453} 12454 12455static void 12456check_status_catch_exception_unhandled (bpstat bs) 12457{ 12458 check_status_exception (ada_catch_exception_unhandled, bs); 12459} 12460 12461static enum print_stop_action 12462print_it_catch_exception_unhandled (bpstat bs) 12463{ 12464 return print_it_exception (ada_catch_exception_unhandled, bs); 12465} 12466 12467static void 12468print_one_catch_exception_unhandled (struct breakpoint *b, 12469 struct bp_location **last_loc) 12470{ 12471 print_one_exception (ada_catch_exception_unhandled, b, last_loc); 12472} 12473 12474static void 12475print_mention_catch_exception_unhandled (struct breakpoint *b) 12476{ 12477 print_mention_exception (ada_catch_exception_unhandled, b); 12478} 12479 12480static void 12481print_recreate_catch_exception_unhandled (struct breakpoint *b, 12482 struct ui_file *fp) 12483{ 12484 print_recreate_exception (ada_catch_exception_unhandled, b, fp); 12485} 12486 12487static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops; 12488 12489/* Virtual table for "catch assert" breakpoints. */ 12490 12491static void 12492dtor_catch_assert (struct breakpoint *b) 12493{ 12494 dtor_exception (ada_catch_assert, b); 12495} 12496 12497static struct bp_location * 12498allocate_location_catch_assert (struct breakpoint *self) 12499{ 12500 return allocate_location_exception (ada_catch_assert, self); 12501} 12502 12503static void 12504re_set_catch_assert (struct breakpoint *b) 12505{ 12506 re_set_exception (ada_catch_assert, b); 12507} 12508 12509static void 12510check_status_catch_assert (bpstat bs) 12511{ 12512 check_status_exception (ada_catch_assert, bs); 12513} 12514 12515static enum print_stop_action 12516print_it_catch_assert (bpstat bs) 12517{ 12518 return print_it_exception (ada_catch_assert, bs); 12519} 12520 12521static void 12522print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc) 12523{ 12524 print_one_exception (ada_catch_assert, b, last_loc); 12525} 12526 12527static void 12528print_mention_catch_assert (struct breakpoint *b) 12529{ 12530 print_mention_exception (ada_catch_assert, b); 12531} 12532 12533static void 12534print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp) 12535{ 12536 print_recreate_exception (ada_catch_assert, b, fp); 12537} 12538 12539static struct breakpoint_ops catch_assert_breakpoint_ops; 12540 12541/* Return a newly allocated copy of the first space-separated token 12542 in ARGSP, and then adjust ARGSP to point immediately after that 12543 token. 12544 12545 Return NULL if ARGPS does not contain any more tokens. */ 12546 12547static char * 12548ada_get_next_arg (char **argsp) 12549{ 12550 char *args = *argsp; 12551 char *end; 12552 char *result; 12553 12554 args = skip_spaces (args); 12555 if (args[0] == '\0') 12556 return NULL; /* No more arguments. */ 12557 12558 /* Find the end of the current argument. */ 12559 12560 end = skip_to_space (args); 12561 12562 /* Adjust ARGSP to point to the start of the next argument. */ 12563 12564 *argsp = end; 12565 12566 /* Make a copy of the current argument and return it. */ 12567 12568 result = xmalloc (end - args + 1); 12569 strncpy (result, args, end - args); 12570 result[end - args] = '\0'; 12571 12572 return result; 12573} 12574 12575/* Split the arguments specified in a "catch exception" command. 12576 Set EX to the appropriate catchpoint type. 12577 Set EXCEP_STRING to the name of the specific exception if 12578 specified by the user. 12579 If a condition is found at the end of the arguments, the condition 12580 expression is stored in COND_STRING (memory must be deallocated 12581 after use). Otherwise COND_STRING is set to NULL. */ 12582 12583static void 12584catch_ada_exception_command_split (char *args, 12585 enum ada_exception_catchpoint_kind *ex, 12586 char **excep_string, 12587 char **cond_string) 12588{ 12589 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL); 12590 char *exception_name; 12591 char *cond = NULL; 12592 12593 exception_name = ada_get_next_arg (&args); 12594 if (exception_name != NULL && strcmp (exception_name, "if") == 0) 12595 { 12596 /* This is not an exception name; this is the start of a condition 12597 expression for a catchpoint on all exceptions. So, "un-get" 12598 this token, and set exception_name to NULL. */ 12599 xfree (exception_name); 12600 exception_name = NULL; 12601 args -= 2; 12602 } 12603 make_cleanup (xfree, exception_name); 12604 12605 /* Check to see if we have a condition. */ 12606 12607 args = skip_spaces (args); 12608 if (startswith (args, "if") 12609 && (isspace (args[2]) || args[2] == '\0')) 12610 { 12611 args += 2; 12612 args = skip_spaces (args); 12613 12614 if (args[0] == '\0') 12615 error (_("Condition missing after `if' keyword")); 12616 cond = xstrdup (args); 12617 make_cleanup (xfree, cond); 12618 12619 args += strlen (args); 12620 } 12621 12622 /* Check that we do not have any more arguments. Anything else 12623 is unexpected. */ 12624 12625 if (args[0] != '\0') 12626 error (_("Junk at end of expression")); 12627 12628 discard_cleanups (old_chain); 12629 12630 if (exception_name == NULL) 12631 { 12632 /* Catch all exceptions. */ 12633 *ex = ada_catch_exception; 12634 *excep_string = NULL; 12635 } 12636 else if (strcmp (exception_name, "unhandled") == 0) 12637 { 12638 /* Catch unhandled exceptions. */ 12639 *ex = ada_catch_exception_unhandled; 12640 *excep_string = NULL; 12641 } 12642 else 12643 { 12644 /* Catch a specific exception. */ 12645 *ex = ada_catch_exception; 12646 *excep_string = exception_name; 12647 } 12648 *cond_string = cond; 12649} 12650 12651/* Return the name of the symbol on which we should break in order to 12652 implement a catchpoint of the EX kind. */ 12653 12654static const char * 12655ada_exception_sym_name (enum ada_exception_catchpoint_kind ex) 12656{ 12657 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ()); 12658 12659 gdb_assert (data->exception_info != NULL); 12660 12661 switch (ex) 12662 { 12663 case ada_catch_exception: 12664 return (data->exception_info->catch_exception_sym); 12665 break; 12666 case ada_catch_exception_unhandled: 12667 return (data->exception_info->catch_exception_unhandled_sym); 12668 break; 12669 case ada_catch_assert: 12670 return (data->exception_info->catch_assert_sym); 12671 break; 12672 default: 12673 internal_error (__FILE__, __LINE__, 12674 _("unexpected catchpoint kind (%d)"), ex); 12675 } 12676} 12677 12678/* Return the breakpoint ops "virtual table" used for catchpoints 12679 of the EX kind. */ 12680 12681static const struct breakpoint_ops * 12682ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex) 12683{ 12684 switch (ex) 12685 { 12686 case ada_catch_exception: 12687 return (&catch_exception_breakpoint_ops); 12688 break; 12689 case ada_catch_exception_unhandled: 12690 return (&catch_exception_unhandled_breakpoint_ops); 12691 break; 12692 case ada_catch_assert: 12693 return (&catch_assert_breakpoint_ops); 12694 break; 12695 default: 12696 internal_error (__FILE__, __LINE__, 12697 _("unexpected catchpoint kind (%d)"), ex); 12698 } 12699} 12700 12701/* Return the condition that will be used to match the current exception 12702 being raised with the exception that the user wants to catch. This 12703 assumes that this condition is used when the inferior just triggered 12704 an exception catchpoint. 12705 12706 The string returned is a newly allocated string that needs to be 12707 deallocated later. */ 12708 12709static char * 12710ada_exception_catchpoint_cond_string (const char *excep_string) 12711{ 12712 int i; 12713 12714 /* The standard exceptions are a special case. They are defined in 12715 runtime units that have been compiled without debugging info; if 12716 EXCEP_STRING is the not-fully-qualified name of a standard 12717 exception (e.g. "constraint_error") then, during the evaluation 12718 of the condition expression, the symbol lookup on this name would 12719 *not* return this standard exception. The catchpoint condition 12720 may then be set only on user-defined exceptions which have the 12721 same not-fully-qualified name (e.g. my_package.constraint_error). 12722 12723 To avoid this unexcepted behavior, these standard exceptions are 12724 systematically prefixed by "standard". This means that "catch 12725 exception constraint_error" is rewritten into "catch exception 12726 standard.constraint_error". 12727 12728 If an exception named contraint_error is defined in another package of 12729 the inferior program, then the only way to specify this exception as a 12730 breakpoint condition is to use its fully-qualified named: 12731 e.g. my_package.constraint_error. */ 12732 12733 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++) 12734 { 12735 if (strcmp (standard_exc [i], excep_string) == 0) 12736 { 12737 return xstrprintf ("long_integer (e) = long_integer (&standard.%s)", 12738 excep_string); 12739 } 12740 } 12741 return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string); 12742} 12743 12744/* Return the symtab_and_line that should be used to insert an exception 12745 catchpoint of the TYPE kind. 12746 12747 EXCEP_STRING should contain the name of a specific exception that 12748 the catchpoint should catch, or NULL otherwise. 12749 12750 ADDR_STRING returns the name of the function where the real 12751 breakpoint that implements the catchpoints is set, depending on the 12752 type of catchpoint we need to create. */ 12753 12754static struct symtab_and_line 12755ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string, 12756 char **addr_string, const struct breakpoint_ops **ops) 12757{ 12758 const char *sym_name; 12759 struct symbol *sym; 12760 12761 /* First, find out which exception support info to use. */ 12762 ada_exception_support_info_sniffer (); 12763 12764 /* Then lookup the function on which we will break in order to catch 12765 the Ada exceptions requested by the user. */ 12766 sym_name = ada_exception_sym_name (ex); 12767 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN); 12768 12769 /* We can assume that SYM is not NULL at this stage. If the symbol 12770 did not exist, ada_exception_support_info_sniffer would have 12771 raised an exception. 12772 12773 Also, ada_exception_support_info_sniffer should have already 12774 verified that SYM is a function symbol. */ 12775 gdb_assert (sym != NULL); 12776 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK); 12777 12778 /* Set ADDR_STRING. */ 12779 *addr_string = xstrdup (sym_name); 12780 12781 /* Set OPS. */ 12782 *ops = ada_exception_breakpoint_ops (ex); 12783 12784 return find_function_start_sal (sym, 1); 12785} 12786 12787/* Create an Ada exception catchpoint. 12788 12789 EX_KIND is the kind of exception catchpoint to be created. 12790 12791 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger 12792 for all exceptions. Otherwise, EXCEPT_STRING indicates the name 12793 of the exception to which this catchpoint applies. When not NULL, 12794 the string must be allocated on the heap, and its deallocation 12795 is no longer the responsibility of the caller. 12796 12797 COND_STRING, if not NULL, is the catchpoint condition. This string 12798 must be allocated on the heap, and its deallocation is no longer 12799 the responsibility of the caller. 12800 12801 TEMPFLAG, if nonzero, means that the underlying breakpoint 12802 should be temporary. 12803 12804 FROM_TTY is the usual argument passed to all commands implementations. */ 12805 12806void 12807create_ada_exception_catchpoint (struct gdbarch *gdbarch, 12808 enum ada_exception_catchpoint_kind ex_kind, 12809 char *excep_string, 12810 char *cond_string, 12811 int tempflag, 12812 int disabled, 12813 int from_tty) 12814{ 12815 struct ada_catchpoint *c; 12816 char *addr_string = NULL; 12817 const struct breakpoint_ops *ops = NULL; 12818 struct symtab_and_line sal 12819 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops); 12820 12821 c = XNEW (struct ada_catchpoint); 12822 init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string, 12823 ops, tempflag, disabled, from_tty); 12824 c->excep_string = excep_string; 12825 create_excep_cond_exprs (c); 12826 if (cond_string != NULL) 12827 set_breakpoint_condition (&c->base, cond_string, from_tty); 12828 install_breakpoint (0, &c->base, 1); 12829} 12830 12831/* Implement the "catch exception" command. */ 12832 12833static void 12834catch_ada_exception_command (char *arg, int from_tty, 12835 struct cmd_list_element *command) 12836{ 12837 struct gdbarch *gdbarch = get_current_arch (); 12838 int tempflag; 12839 enum ada_exception_catchpoint_kind ex_kind; 12840 char *excep_string = NULL; 12841 char *cond_string = NULL; 12842 12843 tempflag = get_cmd_context (command) == CATCH_TEMPORARY; 12844 12845 if (!arg) 12846 arg = ""; 12847 catch_ada_exception_command_split (arg, &ex_kind, &excep_string, 12848 &cond_string); 12849 create_ada_exception_catchpoint (gdbarch, ex_kind, 12850 excep_string, cond_string, 12851 tempflag, 1 /* enabled */, 12852 from_tty); 12853} 12854 12855/* Split the arguments specified in a "catch assert" command. 12856 12857 ARGS contains the command's arguments (or the empty string if 12858 no arguments were passed). 12859 12860 If ARGS contains a condition, set COND_STRING to that condition 12861 (the memory needs to be deallocated after use). */ 12862 12863static void 12864catch_ada_assert_command_split (char *args, char **cond_string) 12865{ 12866 args = skip_spaces (args); 12867 12868 /* Check whether a condition was provided. */ 12869 if (startswith (args, "if") 12870 && (isspace (args[2]) || args[2] == '\0')) 12871 { 12872 args += 2; 12873 args = skip_spaces (args); 12874 if (args[0] == '\0') 12875 error (_("condition missing after `if' keyword")); 12876 *cond_string = xstrdup (args); 12877 } 12878 12879 /* Otherwise, there should be no other argument at the end of 12880 the command. */ 12881 else if (args[0] != '\0') 12882 error (_("Junk at end of arguments.")); 12883} 12884 12885/* Implement the "catch assert" command. */ 12886 12887static void 12888catch_assert_command (char *arg, int from_tty, 12889 struct cmd_list_element *command) 12890{ 12891 struct gdbarch *gdbarch = get_current_arch (); 12892 int tempflag; 12893 char *cond_string = NULL; 12894 12895 tempflag = get_cmd_context (command) == CATCH_TEMPORARY; 12896 12897 if (!arg) 12898 arg = ""; 12899 catch_ada_assert_command_split (arg, &cond_string); 12900 create_ada_exception_catchpoint (gdbarch, ada_catch_assert, 12901 NULL, cond_string, 12902 tempflag, 1 /* enabled */, 12903 from_tty); 12904} 12905 12906/* Return non-zero if the symbol SYM is an Ada exception object. */ 12907 12908static int 12909ada_is_exception_sym (struct symbol *sym) 12910{ 12911 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym)); 12912 12913 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF 12914 && SYMBOL_CLASS (sym) != LOC_BLOCK 12915 && SYMBOL_CLASS (sym) != LOC_CONST 12916 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED 12917 && type_name != NULL && strcmp (type_name, "exception") == 0); 12918} 12919 12920/* Given a global symbol SYM, return non-zero iff SYM is a non-standard 12921 Ada exception object. This matches all exceptions except the ones 12922 defined by the Ada language. */ 12923 12924static int 12925ada_is_non_standard_exception_sym (struct symbol *sym) 12926{ 12927 int i; 12928 12929 if (!ada_is_exception_sym (sym)) 12930 return 0; 12931 12932 for (i = 0; i < ARRAY_SIZE (standard_exc); i++) 12933 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0) 12934 return 0; /* A standard exception. */ 12935 12936 /* Numeric_Error is also a standard exception, so exclude it. 12937 See the STANDARD_EXC description for more details as to why 12938 this exception is not listed in that array. */ 12939 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0) 12940 return 0; 12941 12942 return 1; 12943} 12944 12945/* A helper function for qsort, comparing two struct ada_exc_info 12946 objects. 12947 12948 The comparison is determined first by exception name, and then 12949 by exception address. */ 12950 12951static int 12952compare_ada_exception_info (const void *a, const void *b) 12953{ 12954 const struct ada_exc_info *exc_a = (struct ada_exc_info *) a; 12955 const struct ada_exc_info *exc_b = (struct ada_exc_info *) b; 12956 int result; 12957 12958 result = strcmp (exc_a->name, exc_b->name); 12959 if (result != 0) 12960 return result; 12961 12962 if (exc_a->addr < exc_b->addr) 12963 return -1; 12964 if (exc_a->addr > exc_b->addr) 12965 return 1; 12966 12967 return 0; 12968} 12969 12970/* Sort EXCEPTIONS using compare_ada_exception_info as the comparison 12971 routine, but keeping the first SKIP elements untouched. 12972 12973 All duplicates are also removed. */ 12974 12975static void 12976sort_remove_dups_ada_exceptions_list (VEC(ada_exc_info) **exceptions, 12977 int skip) 12978{ 12979 struct ada_exc_info *to_sort 12980 = VEC_address (ada_exc_info, *exceptions) + skip; 12981 int to_sort_len 12982 = VEC_length (ada_exc_info, *exceptions) - skip; 12983 int i, j; 12984 12985 qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info), 12986 compare_ada_exception_info); 12987 12988 for (i = 1, j = 1; i < to_sort_len; i++) 12989 if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0) 12990 to_sort[j++] = to_sort[i]; 12991 to_sort_len = j; 12992 VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len); 12993} 12994 12995/* A function intended as the "name_matcher" callback in the struct 12996 quick_symbol_functions' expand_symtabs_matching method. 12997 12998 SEARCH_NAME is the symbol's search name. 12999 13000 If USER_DATA is not NULL, it is a pointer to a regext_t object 13001 used to match the symbol (by natural name). Otherwise, when USER_DATA 13002 is null, no filtering is performed, and all symbols are a positive 13003 match. */ 13004 13005static int 13006ada_exc_search_name_matches (const char *search_name, void *user_data) 13007{ 13008 regex_t *preg = user_data; 13009 13010 if (preg == NULL) 13011 return 1; 13012 13013 /* In Ada, the symbol "search name" is a linkage name, whereas 13014 the regular expression used to do the matching refers to 13015 the natural name. So match against the decoded name. */ 13016 return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0); 13017} 13018 13019/* Add all exceptions defined by the Ada standard whose name match 13020 a regular expression. 13021 13022 If PREG is not NULL, then this regexp_t object is used to 13023 perform the symbol name matching. Otherwise, no name-based 13024 filtering is performed. 13025 13026 EXCEPTIONS is a vector of exceptions to which matching exceptions 13027 gets pushed. */ 13028 13029static void 13030ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions) 13031{ 13032 int i; 13033 13034 for (i = 0; i < ARRAY_SIZE (standard_exc); i++) 13035 { 13036 if (preg == NULL 13037 || regexec (preg, standard_exc[i], 0, NULL, 0) == 0) 13038 { 13039 struct bound_minimal_symbol msymbol 13040 = ada_lookup_simple_minsym (standard_exc[i]); 13041 13042 if (msymbol.minsym != NULL) 13043 { 13044 struct ada_exc_info info 13045 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)}; 13046 13047 VEC_safe_push (ada_exc_info, *exceptions, &info); 13048 } 13049 } 13050 } 13051} 13052 13053/* Add all Ada exceptions defined locally and accessible from the given 13054 FRAME. 13055 13056 If PREG is not NULL, then this regexp_t object is used to 13057 perform the symbol name matching. Otherwise, no name-based 13058 filtering is performed. 13059 13060 EXCEPTIONS is a vector of exceptions to which matching exceptions 13061 gets pushed. */ 13062 13063static void 13064ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame, 13065 VEC(ada_exc_info) **exceptions) 13066{ 13067 const struct block *block = get_frame_block (frame, 0); 13068 13069 while (block != 0) 13070 { 13071 struct block_iterator iter; 13072 struct symbol *sym; 13073 13074 ALL_BLOCK_SYMBOLS (block, iter, sym) 13075 { 13076 switch (SYMBOL_CLASS (sym)) 13077 { 13078 case LOC_TYPEDEF: 13079 case LOC_BLOCK: 13080 case LOC_CONST: 13081 break; 13082 default: 13083 if (ada_is_exception_sym (sym)) 13084 { 13085 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym), 13086 SYMBOL_VALUE_ADDRESS (sym)}; 13087 13088 VEC_safe_push (ada_exc_info, *exceptions, &info); 13089 } 13090 } 13091 } 13092 if (BLOCK_FUNCTION (block) != NULL) 13093 break; 13094 block = BLOCK_SUPERBLOCK (block); 13095 } 13096} 13097 13098/* Add all exceptions defined globally whose name name match 13099 a regular expression, excluding standard exceptions. 13100 13101 The reason we exclude standard exceptions is that they need 13102 to be handled separately: Standard exceptions are defined inside 13103 a runtime unit which is normally not compiled with debugging info, 13104 and thus usually do not show up in our symbol search. However, 13105 if the unit was in fact built with debugging info, we need to 13106 exclude them because they would duplicate the entry we found 13107 during the special loop that specifically searches for those 13108 standard exceptions. 13109 13110 If PREG is not NULL, then this regexp_t object is used to 13111 perform the symbol name matching. Otherwise, no name-based 13112 filtering is performed. 13113 13114 EXCEPTIONS is a vector of exceptions to which matching exceptions 13115 gets pushed. */ 13116 13117static void 13118ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions) 13119{ 13120 struct objfile *objfile; 13121 struct compunit_symtab *s; 13122 13123 expand_symtabs_matching (NULL, ada_exc_search_name_matches, NULL, 13124 VARIABLES_DOMAIN, preg); 13125 13126 ALL_COMPUNITS (objfile, s) 13127 { 13128 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s); 13129 int i; 13130 13131 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++) 13132 { 13133 struct block *b = BLOCKVECTOR_BLOCK (bv, i); 13134 struct block_iterator iter; 13135 struct symbol *sym; 13136 13137 ALL_BLOCK_SYMBOLS (b, iter, sym) 13138 if (ada_is_non_standard_exception_sym (sym) 13139 && (preg == NULL 13140 || regexec (preg, SYMBOL_NATURAL_NAME (sym), 13141 0, NULL, 0) == 0)) 13142 { 13143 struct ada_exc_info info 13144 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)}; 13145 13146 VEC_safe_push (ada_exc_info, *exceptions, &info); 13147 } 13148 } 13149 } 13150} 13151 13152/* Implements ada_exceptions_list with the regular expression passed 13153 as a regex_t, rather than a string. 13154 13155 If not NULL, PREG is used to filter out exceptions whose names 13156 do not match. Otherwise, all exceptions are listed. */ 13157 13158static VEC(ada_exc_info) * 13159ada_exceptions_list_1 (regex_t *preg) 13160{ 13161 VEC(ada_exc_info) *result = NULL; 13162 struct cleanup *old_chain 13163 = make_cleanup (VEC_cleanup (ada_exc_info), &result); 13164 int prev_len; 13165 13166 /* First, list the known standard exceptions. These exceptions 13167 need to be handled separately, as they are usually defined in 13168 runtime units that have been compiled without debugging info. */ 13169 13170 ada_add_standard_exceptions (preg, &result); 13171 13172 /* Next, find all exceptions whose scope is local and accessible 13173 from the currently selected frame. */ 13174 13175 if (has_stack_frames ()) 13176 { 13177 prev_len = VEC_length (ada_exc_info, result); 13178 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL), 13179 &result); 13180 if (VEC_length (ada_exc_info, result) > prev_len) 13181 sort_remove_dups_ada_exceptions_list (&result, prev_len); 13182 } 13183 13184 /* Add all exceptions whose scope is global. */ 13185 13186 prev_len = VEC_length (ada_exc_info, result); 13187 ada_add_global_exceptions (preg, &result); 13188 if (VEC_length (ada_exc_info, result) > prev_len) 13189 sort_remove_dups_ada_exceptions_list (&result, prev_len); 13190 13191 discard_cleanups (old_chain); 13192 return result; 13193} 13194 13195/* Return a vector of ada_exc_info. 13196 13197 If REGEXP is NULL, all exceptions are included in the result. 13198 Otherwise, it should contain a valid regular expression, 13199 and only the exceptions whose names match that regular expression 13200 are included in the result. 13201 13202 The exceptions are sorted in the following order: 13203 - Standard exceptions (defined by the Ada language), in 13204 alphabetical order; 13205 - Exceptions only visible from the current frame, in 13206 alphabetical order; 13207 - Exceptions whose scope is global, in alphabetical order. */ 13208 13209VEC(ada_exc_info) * 13210ada_exceptions_list (const char *regexp) 13211{ 13212 VEC(ada_exc_info) *result = NULL; 13213 struct cleanup *old_chain = NULL; 13214 regex_t reg; 13215 13216 if (regexp != NULL) 13217 old_chain = compile_rx_or_error (®, regexp, 13218 _("invalid regular expression")); 13219 13220 result = ada_exceptions_list_1 (regexp != NULL ? ® : NULL); 13221 13222 if (old_chain != NULL) 13223 do_cleanups (old_chain); 13224 return result; 13225} 13226 13227/* Implement the "info exceptions" command. */ 13228 13229static void 13230info_exceptions_command (char *regexp, int from_tty) 13231{ 13232 VEC(ada_exc_info) *exceptions; 13233 struct cleanup *cleanup; 13234 struct gdbarch *gdbarch = get_current_arch (); 13235 int ix; 13236 struct ada_exc_info *info; 13237 13238 exceptions = ada_exceptions_list (regexp); 13239 cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions); 13240 13241 if (regexp != NULL) 13242 printf_filtered 13243 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp); 13244 else 13245 printf_filtered (_("All defined Ada exceptions:\n")); 13246 13247 for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++) 13248 printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr)); 13249 13250 do_cleanups (cleanup); 13251} 13252 13253 /* Operators */ 13254/* Information about operators given special treatment in functions 13255 below. */ 13256/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */ 13257 13258#define ADA_OPERATORS \ 13259 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \ 13260 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \ 13261 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \ 13262 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \ 13263 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \ 13264 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \ 13265 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \ 13266 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \ 13267 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \ 13268 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \ 13269 OP_DEFN (OP_ATR_POS, 1, 2, 0) \ 13270 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \ 13271 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \ 13272 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \ 13273 OP_DEFN (UNOP_QUAL, 3, 1, 0) \ 13274 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \ 13275 OP_DEFN (OP_OTHERS, 1, 1, 0) \ 13276 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \ 13277 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0) 13278 13279static void 13280ada_operator_length (const struct expression *exp, int pc, int *oplenp, 13281 int *argsp) 13282{ 13283 switch (exp->elts[pc - 1].opcode) 13284 { 13285 default: 13286 operator_length_standard (exp, pc, oplenp, argsp); 13287 break; 13288 13289#define OP_DEFN(op, len, args, binop) \ 13290 case op: *oplenp = len; *argsp = args; break; 13291 ADA_OPERATORS; 13292#undef OP_DEFN 13293 13294 case OP_AGGREGATE: 13295 *oplenp = 3; 13296 *argsp = longest_to_int (exp->elts[pc - 2].longconst); 13297 break; 13298 13299 case OP_CHOICES: 13300 *oplenp = 3; 13301 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1; 13302 break; 13303 } 13304} 13305 13306/* Implementation of the exp_descriptor method operator_check. */ 13307 13308static int 13309ada_operator_check (struct expression *exp, int pos, 13310 int (*objfile_func) (struct objfile *objfile, void *data), 13311 void *data) 13312{ 13313 const union exp_element *const elts = exp->elts; 13314 struct type *type = NULL; 13315 13316 switch (elts[pos].opcode) 13317 { 13318 case UNOP_IN_RANGE: 13319 case UNOP_QUAL: 13320 type = elts[pos + 1].type; 13321 break; 13322 13323 default: 13324 return operator_check_standard (exp, pos, objfile_func, data); 13325 } 13326 13327 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */ 13328 13329 if (type && TYPE_OBJFILE (type) 13330 && (*objfile_func) (TYPE_OBJFILE (type), data)) 13331 return 1; 13332 13333 return 0; 13334} 13335 13336static char * 13337ada_op_name (enum exp_opcode opcode) 13338{ 13339 switch (opcode) 13340 { 13341 default: 13342 return op_name_standard (opcode); 13343 13344#define OP_DEFN(op, len, args, binop) case op: return #op; 13345 ADA_OPERATORS; 13346#undef OP_DEFN 13347 13348 case OP_AGGREGATE: 13349 return "OP_AGGREGATE"; 13350 case OP_CHOICES: 13351 return "OP_CHOICES"; 13352 case OP_NAME: 13353 return "OP_NAME"; 13354 } 13355} 13356 13357/* As for operator_length, but assumes PC is pointing at the first 13358 element of the operator, and gives meaningful results only for the 13359 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */ 13360 13361static void 13362ada_forward_operator_length (struct expression *exp, int pc, 13363 int *oplenp, int *argsp) 13364{ 13365 switch (exp->elts[pc].opcode) 13366 { 13367 default: 13368 *oplenp = *argsp = 0; 13369 break; 13370 13371#define OP_DEFN(op, len, args, binop) \ 13372 case op: *oplenp = len; *argsp = args; break; 13373 ADA_OPERATORS; 13374#undef OP_DEFN 13375 13376 case OP_AGGREGATE: 13377 *oplenp = 3; 13378 *argsp = longest_to_int (exp->elts[pc + 1].longconst); 13379 break; 13380 13381 case OP_CHOICES: 13382 *oplenp = 3; 13383 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1; 13384 break; 13385 13386 case OP_STRING: 13387 case OP_NAME: 13388 { 13389 int len = longest_to_int (exp->elts[pc + 1].longconst); 13390 13391 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1); 13392 *argsp = 0; 13393 break; 13394 } 13395 } 13396} 13397 13398static int 13399ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt) 13400{ 13401 enum exp_opcode op = exp->elts[elt].opcode; 13402 int oplen, nargs; 13403 int pc = elt; 13404 int i; 13405 13406 ada_forward_operator_length (exp, elt, &oplen, &nargs); 13407 13408 switch (op) 13409 { 13410 /* Ada attributes ('Foo). */ 13411 case OP_ATR_FIRST: 13412 case OP_ATR_LAST: 13413 case OP_ATR_LENGTH: 13414 case OP_ATR_IMAGE: 13415 case OP_ATR_MAX: 13416 case OP_ATR_MIN: 13417 case OP_ATR_MODULUS: 13418 case OP_ATR_POS: 13419 case OP_ATR_SIZE: 13420 case OP_ATR_TAG: 13421 case OP_ATR_VAL: 13422 break; 13423 13424 case UNOP_IN_RANGE: 13425 case UNOP_QUAL: 13426 /* XXX: gdb_sprint_host_address, type_sprint */ 13427 fprintf_filtered (stream, _("Type @")); 13428 gdb_print_host_address (exp->elts[pc + 1].type, stream); 13429 fprintf_filtered (stream, " ("); 13430 type_print (exp->elts[pc + 1].type, NULL, stream, 0); 13431 fprintf_filtered (stream, ")"); 13432 break; 13433 case BINOP_IN_BOUNDS: 13434 fprintf_filtered (stream, " (%d)", 13435 longest_to_int (exp->elts[pc + 2].longconst)); 13436 break; 13437 case TERNOP_IN_RANGE: 13438 break; 13439 13440 case OP_AGGREGATE: 13441 case OP_OTHERS: 13442 case OP_DISCRETE_RANGE: 13443 case OP_POSITIONAL: 13444 case OP_CHOICES: 13445 break; 13446 13447 case OP_NAME: 13448 case OP_STRING: 13449 { 13450 char *name = &exp->elts[elt + 2].string; 13451 int len = longest_to_int (exp->elts[elt + 1].longconst); 13452 13453 fprintf_filtered (stream, "Text: `%.*s'", len, name); 13454 break; 13455 } 13456 13457 default: 13458 return dump_subexp_body_standard (exp, stream, elt); 13459 } 13460 13461 elt += oplen; 13462 for (i = 0; i < nargs; i += 1) 13463 elt = dump_subexp (exp, stream, elt); 13464 13465 return elt; 13466} 13467 13468/* The Ada extension of print_subexp (q.v.). */ 13469 13470static void 13471ada_print_subexp (struct expression *exp, int *pos, 13472 struct ui_file *stream, enum precedence prec) 13473{ 13474 int oplen, nargs, i; 13475 int pc = *pos; 13476 enum exp_opcode op = exp->elts[pc].opcode; 13477 13478 ada_forward_operator_length (exp, pc, &oplen, &nargs); 13479 13480 *pos += oplen; 13481 switch (op) 13482 { 13483 default: 13484 *pos -= oplen; 13485 print_subexp_standard (exp, pos, stream, prec); 13486 return; 13487 13488 case OP_VAR_VALUE: 13489 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream); 13490 return; 13491 13492 case BINOP_IN_BOUNDS: 13493 /* XXX: sprint_subexp */ 13494 print_subexp (exp, pos, stream, PREC_SUFFIX); 13495 fputs_filtered (" in ", stream); 13496 print_subexp (exp, pos, stream, PREC_SUFFIX); 13497 fputs_filtered ("'range", stream); 13498 if (exp->elts[pc + 1].longconst > 1) 13499 fprintf_filtered (stream, "(%ld)", 13500 (long) exp->elts[pc + 1].longconst); 13501 return; 13502 13503 case TERNOP_IN_RANGE: 13504 if (prec >= PREC_EQUAL) 13505 fputs_filtered ("(", stream); 13506 /* XXX: sprint_subexp */ 13507 print_subexp (exp, pos, stream, PREC_SUFFIX); 13508 fputs_filtered (" in ", stream); 13509 print_subexp (exp, pos, stream, PREC_EQUAL); 13510 fputs_filtered (" .. ", stream); 13511 print_subexp (exp, pos, stream, PREC_EQUAL); 13512 if (prec >= PREC_EQUAL) 13513 fputs_filtered (")", stream); 13514 return; 13515 13516 case OP_ATR_FIRST: 13517 case OP_ATR_LAST: 13518 case OP_ATR_LENGTH: 13519 case OP_ATR_IMAGE: 13520 case OP_ATR_MAX: 13521 case OP_ATR_MIN: 13522 case OP_ATR_MODULUS: 13523 case OP_ATR_POS: 13524 case OP_ATR_SIZE: 13525 case OP_ATR_TAG: 13526 case OP_ATR_VAL: 13527 if (exp->elts[*pos].opcode == OP_TYPE) 13528 { 13529 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID) 13530 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0, 13531 &type_print_raw_options); 13532 *pos += 3; 13533 } 13534 else 13535 print_subexp (exp, pos, stream, PREC_SUFFIX); 13536 fprintf_filtered (stream, "'%s", ada_attribute_name (op)); 13537 if (nargs > 1) 13538 { 13539 int tem; 13540 13541 for (tem = 1; tem < nargs; tem += 1) 13542 { 13543 fputs_filtered ((tem == 1) ? " (" : ", ", stream); 13544 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA); 13545 } 13546 fputs_filtered (")", stream); 13547 } 13548 return; 13549 13550 case UNOP_QUAL: 13551 type_print (exp->elts[pc + 1].type, "", stream, 0); 13552 fputs_filtered ("'(", stream); 13553 print_subexp (exp, pos, stream, PREC_PREFIX); 13554 fputs_filtered (")", stream); 13555 return; 13556 13557 case UNOP_IN_RANGE: 13558 /* XXX: sprint_subexp */ 13559 print_subexp (exp, pos, stream, PREC_SUFFIX); 13560 fputs_filtered (" in ", stream); 13561 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0, 13562 &type_print_raw_options); 13563 return; 13564 13565 case OP_DISCRETE_RANGE: 13566 print_subexp (exp, pos, stream, PREC_SUFFIX); 13567 fputs_filtered ("..", stream); 13568 print_subexp (exp, pos, stream, PREC_SUFFIX); 13569 return; 13570 13571 case OP_OTHERS: 13572 fputs_filtered ("others => ", stream); 13573 print_subexp (exp, pos, stream, PREC_SUFFIX); 13574 return; 13575 13576 case OP_CHOICES: 13577 for (i = 0; i < nargs-1; i += 1) 13578 { 13579 if (i > 0) 13580 fputs_filtered ("|", stream); 13581 print_subexp (exp, pos, stream, PREC_SUFFIX); 13582 } 13583 fputs_filtered (" => ", stream); 13584 print_subexp (exp, pos, stream, PREC_SUFFIX); 13585 return; 13586 13587 case OP_POSITIONAL: 13588 print_subexp (exp, pos, stream, PREC_SUFFIX); 13589 return; 13590 13591 case OP_AGGREGATE: 13592 fputs_filtered ("(", stream); 13593 for (i = 0; i < nargs; i += 1) 13594 { 13595 if (i > 0) 13596 fputs_filtered (", ", stream); 13597 print_subexp (exp, pos, stream, PREC_SUFFIX); 13598 } 13599 fputs_filtered (")", stream); 13600 return; 13601 } 13602} 13603 13604/* Table mapping opcodes into strings for printing operators 13605 and precedences of the operators. */ 13606 13607static const struct op_print ada_op_print_tab[] = { 13608 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1}, 13609 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0}, 13610 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0}, 13611 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0}, 13612 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0}, 13613 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0}, 13614 {"=", BINOP_EQUAL, PREC_EQUAL, 0}, 13615 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0}, 13616 {"<=", BINOP_LEQ, PREC_ORDER, 0}, 13617 {">=", BINOP_GEQ, PREC_ORDER, 0}, 13618 {">", BINOP_GTR, PREC_ORDER, 0}, 13619 {"<", BINOP_LESS, PREC_ORDER, 0}, 13620 {">>", BINOP_RSH, PREC_SHIFT, 0}, 13621 {"<<", BINOP_LSH, PREC_SHIFT, 0}, 13622 {"+", BINOP_ADD, PREC_ADD, 0}, 13623 {"-", BINOP_SUB, PREC_ADD, 0}, 13624 {"&", BINOP_CONCAT, PREC_ADD, 0}, 13625 {"*", BINOP_MUL, PREC_MUL, 0}, 13626 {"/", BINOP_DIV, PREC_MUL, 0}, 13627 {"rem", BINOP_REM, PREC_MUL, 0}, 13628 {"mod", BINOP_MOD, PREC_MUL, 0}, 13629 {"**", BINOP_EXP, PREC_REPEAT, 0}, 13630 {"@", BINOP_REPEAT, PREC_REPEAT, 0}, 13631 {"-", UNOP_NEG, PREC_PREFIX, 0}, 13632 {"+", UNOP_PLUS, PREC_PREFIX, 0}, 13633 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0}, 13634 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0}, 13635 {"abs ", UNOP_ABS, PREC_PREFIX, 0}, 13636 {".all", UNOP_IND, PREC_SUFFIX, 1}, 13637 {"'access", UNOP_ADDR, PREC_SUFFIX, 1}, 13638 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1}, 13639 {NULL, 0, 0, 0} 13640}; 13641 13642enum ada_primitive_types { 13643 ada_primitive_type_int, 13644 ada_primitive_type_long, 13645 ada_primitive_type_short, 13646 ada_primitive_type_char, 13647 ada_primitive_type_float, 13648 ada_primitive_type_double, 13649 ada_primitive_type_void, 13650 ada_primitive_type_long_long, 13651 ada_primitive_type_long_double, 13652 ada_primitive_type_natural, 13653 ada_primitive_type_positive, 13654 ada_primitive_type_system_address, 13655 nr_ada_primitive_types 13656}; 13657 13658static void 13659ada_language_arch_info (struct gdbarch *gdbarch, 13660 struct language_arch_info *lai) 13661{ 13662 const struct builtin_type *builtin = builtin_type (gdbarch); 13663 13664 lai->primitive_type_vector 13665 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1, 13666 struct type *); 13667 13668 lai->primitive_type_vector [ada_primitive_type_int] 13669 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 13670 0, "integer"); 13671 lai->primitive_type_vector [ada_primitive_type_long] 13672 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 13673 0, "long_integer"); 13674 lai->primitive_type_vector [ada_primitive_type_short] 13675 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 13676 0, "short_integer"); 13677 lai->string_char_type 13678 = lai->primitive_type_vector [ada_primitive_type_char] 13679 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character"); 13680 lai->primitive_type_vector [ada_primitive_type_float] 13681 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), 13682 "float", NULL); 13683 lai->primitive_type_vector [ada_primitive_type_double] 13684 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch), 13685 "long_float", NULL); 13686 lai->primitive_type_vector [ada_primitive_type_long_long] 13687 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 13688 0, "long_long_integer"); 13689 lai->primitive_type_vector [ada_primitive_type_long_double] 13690 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch), 13691 "long_long_float", NULL); 13692 lai->primitive_type_vector [ada_primitive_type_natural] 13693 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 13694 0, "natural"); 13695 lai->primitive_type_vector [ada_primitive_type_positive] 13696 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 13697 0, "positive"); 13698 lai->primitive_type_vector [ada_primitive_type_void] 13699 = builtin->builtin_void; 13700 13701 lai->primitive_type_vector [ada_primitive_type_system_address] 13702 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void")); 13703 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address]) 13704 = "system__address"; 13705 13706 lai->bool_type_symbol = NULL; 13707 lai->bool_type_default = builtin->builtin_bool; 13708} 13709 13710 /* Language vector */ 13711 13712/* Not really used, but needed in the ada_language_defn. */ 13713 13714static void 13715emit_char (int c, struct type *type, struct ui_file *stream, int quoter) 13716{ 13717 ada_emit_char (c, type, stream, quoter, 1); 13718} 13719 13720static int 13721parse (struct parser_state *ps) 13722{ 13723 warnings_issued = 0; 13724 return ada_parse (ps); 13725} 13726 13727static const struct exp_descriptor ada_exp_descriptor = { 13728 ada_print_subexp, 13729 ada_operator_length, 13730 ada_operator_check, 13731 ada_op_name, 13732 ada_dump_subexp_body, 13733 ada_evaluate_subexp 13734}; 13735 13736/* Implement the "la_get_symbol_name_cmp" language_defn method 13737 for Ada. */ 13738 13739static symbol_name_cmp_ftype 13740ada_get_symbol_name_cmp (const char *lookup_name) 13741{ 13742 if (should_use_wild_match (lookup_name)) 13743 return wild_match; 13744 else 13745 return compare_names; 13746} 13747 13748/* Implement the "la_read_var_value" language_defn method for Ada. */ 13749 13750static struct value * 13751ada_read_var_value (struct symbol *var, struct frame_info *frame) 13752{ 13753 const struct block *frame_block = NULL; 13754 struct symbol *renaming_sym = NULL; 13755 13756 /* The only case where default_read_var_value is not sufficient 13757 is when VAR is a renaming... */ 13758 if (frame) 13759 frame_block = get_frame_block (frame, NULL); 13760 if (frame_block) 13761 renaming_sym = ada_find_renaming_symbol (var, frame_block); 13762 if (renaming_sym != NULL) 13763 return ada_read_renaming_var_value (renaming_sym, frame_block); 13764 13765 /* This is a typical case where we expect the default_read_var_value 13766 function to work. */ 13767 return default_read_var_value (var, frame); 13768} 13769 13770const struct language_defn ada_language_defn = { 13771 "ada", /* Language name */ 13772 "Ada", 13773 language_ada, 13774 range_check_off, 13775 case_sensitive_on, /* Yes, Ada is case-insensitive, but 13776 that's not quite what this means. */ 13777 array_row_major, 13778 macro_expansion_no, 13779 &ada_exp_descriptor, 13780 parse, 13781 ada_error, 13782 resolve, 13783 ada_printchar, /* Print a character constant */ 13784 ada_printstr, /* Function to print string constant */ 13785 emit_char, /* Function to print single char (not used) */ 13786 ada_print_type, /* Print a type using appropriate syntax */ 13787 ada_print_typedef, /* Print a typedef using appropriate syntax */ 13788 ada_val_print, /* Print a value using appropriate syntax */ 13789 ada_value_print, /* Print a top-level value */ 13790 ada_read_var_value, /* la_read_var_value */ 13791 NULL, /* Language specific skip_trampoline */ 13792 NULL, /* name_of_this */ 13793 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */ 13794 basic_lookup_transparent_type, /* lookup_transparent_type */ 13795 ada_la_decode, /* Language specific symbol demangler */ 13796 NULL, /* Language specific 13797 class_name_from_physname */ 13798 ada_op_print_tab, /* expression operators for printing */ 13799 0, /* c-style arrays */ 13800 1, /* String lower bound */ 13801 ada_get_gdb_completer_word_break_characters, 13802 ada_make_symbol_completion_list, 13803 ada_language_arch_info, 13804 ada_print_array_index, 13805 default_pass_by_reference, 13806 c_get_string, 13807 ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */ 13808 ada_iterate_over_symbols, 13809 &ada_varobj_ops, 13810 NULL, 13811 NULL, 13812 LANG_MAGIC 13813}; 13814 13815/* Provide a prototype to silence -Wmissing-prototypes. */ 13816extern initialize_file_ftype _initialize_ada_language; 13817 13818/* Command-list for the "set/show ada" prefix command. */ 13819static struct cmd_list_element *set_ada_list; 13820static struct cmd_list_element *show_ada_list; 13821 13822/* Implement the "set ada" prefix command. */ 13823 13824static void 13825set_ada_command (char *arg, int from_tty) 13826{ 13827 printf_unfiltered (_(\ 13828"\"set ada\" must be followed by the name of a setting.\n")); 13829 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout); 13830} 13831 13832/* Implement the "show ada" prefix command. */ 13833 13834static void 13835show_ada_command (char *args, int from_tty) 13836{ 13837 cmd_show_list (show_ada_list, from_tty, ""); 13838} 13839 13840static void 13841initialize_ada_catchpoint_ops (void) 13842{ 13843 struct breakpoint_ops *ops; 13844 13845 initialize_breakpoint_ops (); 13846 13847 ops = &catch_exception_breakpoint_ops; 13848 *ops = bkpt_breakpoint_ops; 13849 ops->dtor = dtor_catch_exception; 13850 ops->allocate_location = allocate_location_catch_exception; 13851 ops->re_set = re_set_catch_exception; 13852 ops->check_status = check_status_catch_exception; 13853 ops->print_it = print_it_catch_exception; 13854 ops->print_one = print_one_catch_exception; 13855 ops->print_mention = print_mention_catch_exception; 13856 ops->print_recreate = print_recreate_catch_exception; 13857 13858 ops = &catch_exception_unhandled_breakpoint_ops; 13859 *ops = bkpt_breakpoint_ops; 13860 ops->dtor = dtor_catch_exception_unhandled; 13861 ops->allocate_location = allocate_location_catch_exception_unhandled; 13862 ops->re_set = re_set_catch_exception_unhandled; 13863 ops->check_status = check_status_catch_exception_unhandled; 13864 ops->print_it = print_it_catch_exception_unhandled; 13865 ops->print_one = print_one_catch_exception_unhandled; 13866 ops->print_mention = print_mention_catch_exception_unhandled; 13867 ops->print_recreate = print_recreate_catch_exception_unhandled; 13868 13869 ops = &catch_assert_breakpoint_ops; 13870 *ops = bkpt_breakpoint_ops; 13871 ops->dtor = dtor_catch_assert; 13872 ops->allocate_location = allocate_location_catch_assert; 13873 ops->re_set = re_set_catch_assert; 13874 ops->check_status = check_status_catch_assert; 13875 ops->print_it = print_it_catch_assert; 13876 ops->print_one = print_one_catch_assert; 13877 ops->print_mention = print_mention_catch_assert; 13878 ops->print_recreate = print_recreate_catch_assert; 13879} 13880 13881/* This module's 'new_objfile' observer. */ 13882 13883static void 13884ada_new_objfile_observer (struct objfile *objfile) 13885{ 13886 ada_clear_symbol_cache (); 13887} 13888 13889/* This module's 'free_objfile' observer. */ 13890 13891static void 13892ada_free_objfile_observer (struct objfile *objfile) 13893{ 13894 ada_clear_symbol_cache (); 13895} 13896 13897void 13898_initialize_ada_language (void) 13899{ 13900 add_language (&ada_language_defn); 13901 13902 initialize_ada_catchpoint_ops (); 13903 13904 add_prefix_cmd ("ada", no_class, set_ada_command, 13905 _("Prefix command for changing Ada-specfic settings"), 13906 &set_ada_list, "set ada ", 0, &setlist); 13907 13908 add_prefix_cmd ("ada", no_class, show_ada_command, 13909 _("Generic command for showing Ada-specific settings."), 13910 &show_ada_list, "show ada ", 0, &showlist); 13911 13912 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure, 13913 &trust_pad_over_xvs, _("\ 13914Enable or disable an optimization trusting PAD types over XVS types"), _("\ 13915Show whether an optimization trusting PAD types over XVS types is activated"), 13916 _("\ 13917This is related to the encoding used by the GNAT compiler. The debugger\n\ 13918should normally trust the contents of PAD types, but certain older versions\n\ 13919of GNAT have a bug that sometimes causes the information in the PAD type\n\ 13920to be incorrect. Turning this setting \"off\" allows the debugger to\n\ 13921work around this bug. It is always safe to turn this option \"off\", but\n\ 13922this incurs a slight performance penalty, so it is recommended to NOT change\n\ 13923this option to \"off\" unless necessary."), 13924 NULL, NULL, &set_ada_list, &show_ada_list); 13925 13926 add_catch_command ("exception", _("\ 13927Catch Ada exceptions, when raised.\n\ 13928With an argument, catch only exceptions with the given name."), 13929 catch_ada_exception_command, 13930 NULL, 13931 CATCH_PERMANENT, 13932 CATCH_TEMPORARY); 13933 add_catch_command ("assert", _("\ 13934Catch failed Ada assertions, when raised.\n\ 13935With an argument, catch only exceptions with the given name."), 13936 catch_assert_command, 13937 NULL, 13938 CATCH_PERMANENT, 13939 CATCH_TEMPORARY); 13940 13941 varsize_limit = 65536; 13942 13943 add_info ("exceptions", info_exceptions_command, 13944 _("\ 13945List all Ada exception names.\n\ 13946If a regular expression is passed as an argument, only those matching\n\ 13947the regular expression are listed.")); 13948 13949 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd, 13950 _("Set Ada maintenance-related variables."), 13951 &maint_set_ada_cmdlist, "maintenance set ada ", 13952 0/*allow-unknown*/, &maintenance_set_cmdlist); 13953 13954 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd, 13955 _("Show Ada maintenance-related variables"), 13956 &maint_show_ada_cmdlist, "maintenance show ada ", 13957 0/*allow-unknown*/, &maintenance_show_cmdlist); 13958 13959 add_setshow_boolean_cmd 13960 ("ignore-descriptive-types", class_maintenance, 13961 &ada_ignore_descriptive_types_p, 13962 _("Set whether descriptive types generated by GNAT should be ignored."), 13963 _("Show whether descriptive types generated by GNAT should be ignored."), 13964 _("\ 13965When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\ 13966DWARF attribute."), 13967 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist); 13968 13969 obstack_init (&symbol_list_obstack); 13970 13971 decoded_names_store = htab_create_alloc 13972 (256, htab_hash_string, (int (*)(const void *, const void *)) streq, 13973 NULL, xcalloc, xfree); 13974 13975 /* The ada-lang observers. */ 13976 observer_attach_new_objfile (ada_new_objfile_observer); 13977 observer_attach_free_objfile (ada_free_objfile_observer); 13978 observer_attach_inferior_exit (ada_inferior_exit); 13979 13980 /* Setup various context-specific data. */ 13981 ada_inferior_data 13982 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup); 13983 ada_pspace_data_handle 13984 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup); 13985} 13986