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