1 /* Ada language support routines for GDB, the GNU debugger. Copyright
2 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004.
3 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
22 /* Sections of code marked
28 indicate sections that are used in sources distributed by
29 ACT, Inc., but not yet integrated into the public tree (where
30 GNAT_GDB is not defined). They are retained here nevertheless
31 to minimize the problems of maintaining different versions
32 of the source and to make the full source available. */
36 #include "gdb_string.h"
40 #include "gdb_regex.h"
45 #include "expression.h"
46 #include "parser-defs.h"
52 #include "breakpoint.h"
55 #include "gdb_obstack.h"
57 #include "completer.h"
64 #include "dictionary.h"
66 #ifndef ADA_RETAIN_DOTS
67 #define ADA_RETAIN_DOTS 0
70 /* Define whether or not the C operator '/' truncates towards zero for
71 differently signed operands (truncation direction is undefined in C).
72 Copied from valarith.c. */
74 #ifndef TRUNCATION_TOWARDS_ZERO
75 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
79 /* A structure that contains a vector of strings.
80 The main purpose of this type is to group the vector and its
81 associated parameters in one structure. This makes it easier
82 to handle and pass around. */
86 char **array
; /* The vector itself. */
87 int index
; /* Index of the next available element in the array. */
88 size_t size
; /* The number of entries allocated in the array. */
91 static struct string_vector
xnew_string_vector (int initial_size
);
92 static void string_vector_append (struct string_vector
*sv
, char *str
);
95 static const char *ada_unqualified_name (const char *decoded_name
);
96 static char *add_angle_brackets (const char *str
);
97 static void extract_string (CORE_ADDR addr
, char *buf
);
98 static char *function_name_from_pc (CORE_ADDR pc
);
100 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
102 static void modify_general_field (char *, LONGEST
, int, int);
104 static struct type
*desc_base_type (struct type
*);
106 static struct type
*desc_bounds_type (struct type
*);
108 static struct value
*desc_bounds (struct value
*);
110 static int fat_pntr_bounds_bitpos (struct type
*);
112 static int fat_pntr_bounds_bitsize (struct type
*);
114 static struct type
*desc_data_type (struct type
*);
116 static struct value
*desc_data (struct value
*);
118 static int fat_pntr_data_bitpos (struct type
*);
120 static int fat_pntr_data_bitsize (struct type
*);
122 static struct value
*desc_one_bound (struct value
*, int, int);
124 static int desc_bound_bitpos (struct type
*, int, int);
126 static int desc_bound_bitsize (struct type
*, int, int);
128 static struct type
*desc_index_type (struct type
*, int);
130 static int desc_arity (struct type
*);
132 static int ada_type_match (struct type
*, struct type
*, int);
134 static int ada_args_match (struct symbol
*, struct value
**, int);
136 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
138 static struct value
*convert_actual (struct value
*, struct type
*,
141 static struct value
*make_array_descriptor (struct type
*, struct value
*,
144 static void ada_add_block_symbols (struct obstack
*,
145 struct block
*, const char *,
146 domain_enum
, struct objfile
*,
147 struct symtab
*, int);
149 static int is_nonfunction (struct ada_symbol_info
*, int);
151 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
152 struct block
*, struct symtab
*);
154 static int num_defns_collected (struct obstack
*);
156 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
158 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
159 *, const char *, int,
162 static struct symtab
*symtab_for_sym (struct symbol
*);
164 static struct value
*resolve_subexp (struct expression
**, int *, int,
167 static void replace_operator_with_call (struct expression
**, int, int, int,
168 struct symbol
*, struct block
*);
170 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
172 static char *ada_op_name (enum exp_opcode
);
174 static const char *ada_decoded_op_name (enum exp_opcode
);
176 static int numeric_type_p (struct type
*);
178 static int integer_type_p (struct type
*);
180 static int scalar_type_p (struct type
*);
182 static int discrete_type_p (struct type
*);
184 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
187 static char *extended_canonical_line_spec (struct symtab_and_line
,
190 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
193 static struct value
*evaluate_subexp_type (struct expression
*, int *);
195 static int is_dynamic_field (struct type
*, int);
197 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
198 CORE_ADDR
, struct value
*);
200 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
202 static struct type
*to_fixed_range_type (char *, struct value
*,
205 static struct type
*to_static_fixed_type (struct type
*);
207 static struct value
*unwrap_value (struct value
*);
209 static struct type
*packed_array_type (struct type
*, long *);
211 static struct type
*decode_packed_array_type (struct type
*);
213 static struct value
*decode_packed_array (struct value
*);
215 static struct value
*value_subscript_packed (struct value
*, int,
218 static struct value
*coerce_unspec_val_to_type (struct value
*,
221 static struct value
*get_var_value (char *, char *);
223 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
225 static int equiv_types (struct type
*, struct type
*);
227 static int is_name_suffix (const char *);
229 static int wild_match (const char *, int, const char *);
231 static struct symtabs_and_lines
232 find_sal_from_funcs_and_line (const char *, int,
233 struct ada_symbol_info
*, int);
235 static int find_line_in_linetable (struct linetable
*, int,
236 struct ada_symbol_info
*, int, int *);
238 static int find_next_line_in_linetable (struct linetable
*, int, int, int);
240 static void read_all_symtabs (const char *);
242 static int is_plausible_func_for_line (struct symbol
*, int);
244 static struct value
*ada_coerce_ref (struct value
*);
246 static LONGEST
pos_atr (struct value
*);
248 static struct value
*value_pos_atr (struct value
*);
250 static struct value
*value_val_atr (struct type
*, struct value
*);
252 static struct symbol
*standard_lookup (const char *, const struct block
*,
255 static struct value
*ada_search_struct_field (char *, struct value
*, int,
258 static struct value
*ada_value_primitive_field (struct value
*, int, int,
261 static int find_struct_field (char *, struct type
*, int,
262 struct type
**, int *, int *, int *);
264 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
267 static struct value
*ada_to_fixed_value (struct value
*);
269 static void adjust_pc_past_prologue (CORE_ADDR
*);
271 static int ada_resolve_function (struct ada_symbol_info
*, int,
272 struct value
**, int, const char *,
275 static struct value
*ada_coerce_to_simple_array (struct value
*);
277 static int ada_is_direct_array_type (struct type
*);
279 static void error_breakpoint_runtime_sym_not_found (const char *err_desc
);
281 static int is_runtime_sym_defined (const char *name
, int allow_tramp
);
283 static void ada_language_arch_info (struct gdbarch
*,
284 struct language_arch_info
*);
286 static void check_size (const struct type
*);
290 /* Maximum-sized dynamic type. */
291 static unsigned int varsize_limit
;
293 /* FIXME: brobecker/2003-09-17: No longer a const because it is
294 returned by a function that does not return a const char *. */
295 static char *ada_completer_word_break_characters
=
297 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
299 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
302 /* The name of the symbol to use to get the name of the main subprogram. */
303 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
304 = "__gnat_ada_main_program_name";
306 /* The name of the runtime function called when an exception is raised. */
307 static const char raise_sym_name
[] = "__gnat_raise_nodefer_with_msg";
309 /* The name of the runtime function called when an unhandled exception
311 static const char raise_unhandled_sym_name
[] = "__gnat_unhandled_exception";
313 /* The name of the runtime function called when an assert failure is
315 static const char raise_assert_sym_name
[] =
316 "system__assertions__raise_assert_failure";
318 /* When GDB stops on an unhandled exception, GDB will go up the stack until
319 if finds a frame corresponding to this function, in order to extract the
320 name of the exception that has been raised from one of the parameters. */
321 static const char process_raise_exception_name
[] =
322 "ada__exceptions__process_raise_exception";
324 /* A string that reflects the longest exception expression rewrite,
325 aside from the exception name. */
326 static const char longest_exception_template
[] =
327 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
329 /* Limit on the number of warnings to raise per expression evaluation. */
330 static int warning_limit
= 2;
332 /* Number of warning messages issued; reset to 0 by cleanups after
333 expression evaluation. */
334 static int warnings_issued
= 0;
336 static const char *known_runtime_file_name_patterns
[] = {
337 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
340 static const char *known_auxiliary_function_name_patterns
[] = {
341 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
344 /* Space for allocating results of ada_lookup_symbol_list. */
345 static struct obstack symbol_list_obstack
;
351 /* Create a new empty string_vector struct with an initial size of
354 static struct string_vector
355 xnew_string_vector (int initial_size
)
357 struct string_vector result
;
359 result
.array
= (char **) xmalloc ((initial_size
+ 1) * sizeof (char *));
361 result
.size
= initial_size
;
366 /* Add STR at the end of the given string vector SV. If SV is already
367 full, its size is automatically increased (doubled). */
370 string_vector_append (struct string_vector
*sv
, char *str
)
372 if (sv
->index
>= sv
->size
)
373 GROW_VECT (sv
->array
, sv
->size
, sv
->size
* 2);
375 sv
->array
[sv
->index
] = str
;
379 /* Given DECODED_NAME a string holding a symbol name in its
380 decoded form (ie using the Ada dotted notation), returns
381 its unqualified name. */
384 ada_unqualified_name (const char *decoded_name
)
386 const char *result
= strrchr (decoded_name
, '.');
389 result
++; /* Skip the dot... */
391 result
= decoded_name
;
396 /* Return a string starting with '<', followed by STR, and '>'.
397 The result is good until the next call. */
400 add_angle_brackets (const char *str
)
402 static char *result
= NULL
;
405 result
= (char *) xmalloc ((strlen (str
) + 3) * sizeof (char));
407 sprintf (result
, "<%s>", str
);
411 #endif /* GNAT_GDB */
414 ada_get_gdb_completer_word_break_characters (void)
416 return ada_completer_word_break_characters
;
419 /* Read the string located at ADDR from the inferior and store the
423 extract_string (CORE_ADDR addr
, char *buf
)
427 /* Loop, reading one byte at a time, until we reach the '\000'
428 end-of-string marker. */
431 target_read_memory (addr
+ char_index
* sizeof (char),
432 buf
+ char_index
* sizeof (char), sizeof (char));
435 while (buf
[char_index
- 1] != '\000');
438 /* Return the name of the function owning the instruction located at PC.
439 Return NULL if no such function could be found. */
442 function_name_from_pc (CORE_ADDR pc
)
446 if (!find_pc_partial_function (pc
, &func_name
, NULL
, NULL
))
452 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
453 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
454 updating *OLD_VECT and *SIZE as necessary. */
457 grow_vect (void **old_vect
, size_t * size
, size_t min_size
, int element_size
)
459 if (*size
< min_size
)
462 if (*size
< min_size
)
464 *old_vect
= xrealloc (*old_vect
, *size
* element_size
);
468 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
469 suffix of FIELD_NAME beginning "___". */
472 field_name_match (const char *field_name
, const char *target
)
474 int len
= strlen (target
);
476 (strncmp (field_name
, target
, len
) == 0
477 && (field_name
[len
] == '\0'
478 || (strncmp (field_name
+ len
, "___", 3) == 0
479 && strcmp (field_name
+ strlen (field_name
) - 6,
484 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
485 FIELD_NAME, and return its index. This function also handles fields
486 whose name have ___ suffixes because the compiler sometimes alters
487 their name by adding such a suffix to represent fields with certain
488 constraints. If the field could not be found, return a negative
489 number if MAYBE_MISSING is set. Otherwise raise an error. */
492 ada_get_field_index (const struct type
*type
, const char *field_name
,
496 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
497 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
501 error ("Unable to find field %s in struct %s. Aborting",
502 field_name
, TYPE_NAME (type
));
507 /* The length of the prefix of NAME prior to any "___" suffix. */
510 ada_name_prefix_len (const char *name
)
516 const char *p
= strstr (name
, "___");
518 return strlen (name
);
524 /* Return non-zero if SUFFIX is a suffix of STR.
525 Return zero if STR is null. */
528 is_suffix (const char *str
, const char *suffix
)
534 len2
= strlen (suffix
);
535 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
538 /* Create a value of type TYPE whose contents come from VALADDR, if it
539 is non-null, and whose memory address (in the inferior) is
543 value_from_contents_and_address (struct type
*type
, char *valaddr
,
546 struct value
*v
= allocate_value (type
);
550 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
551 VALUE_ADDRESS (v
) = address
;
553 VALUE_LVAL (v
) = lval_memory
;
557 /* The contents of value VAL, treated as a value of type TYPE. The
558 result is an lval in memory if VAL is. */
560 static struct value
*
561 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
563 CHECK_TYPEDEF (type
);
564 if (VALUE_TYPE (val
) == type
)
568 struct value
*result
;
570 /* Make sure that the object size is not unreasonable before
571 trying to allocate some memory for it. */
572 if (TYPE_LENGTH (type
) > varsize_limit
)
573 error ("object size is larger than varsize-limit");
575 result
= allocate_value (type
);
576 VALUE_LVAL (result
) = VALUE_LVAL (val
);
577 VALUE_BITSIZE (result
) = VALUE_BITSIZE (val
);
578 VALUE_BITPOS (result
) = VALUE_BITPOS (val
);
579 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + VALUE_OFFSET (val
);
581 || TYPE_LENGTH (type
) > TYPE_LENGTH (VALUE_TYPE (val
)))
582 VALUE_LAZY (result
) = 1;
584 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
),
591 cond_offset_host (char *valaddr
, long offset
)
596 return valaddr
+ offset
;
600 cond_offset_target (CORE_ADDR address
, long offset
)
605 return address
+ offset
;
608 /* Issue a warning (as for the definition of warning in utils.c, but
609 with exactly one argument rather than ...), unless the limit on the
610 number of warnings has passed during the evaluation of the current
613 lim_warning (const char *format
, long arg
)
615 warnings_issued
+= 1;
616 if (warnings_issued
<= warning_limit
)
617 warning (format
, arg
);
621 ada_translate_error_message (const char *string
)
623 if (strcmp (string
, "Invalid cast.") == 0)
624 return "Invalid type conversion.";
629 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
630 gdbtypes.h, but some of the necessary definitions in that file
631 seem to have gone missing. */
633 /* Maximum value of a SIZE-byte signed integer type. */
635 max_of_size (int size
)
637 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
638 return top_bit
| (top_bit
- 1);
641 /* Minimum value of a SIZE-byte signed integer type. */
643 min_of_size (int size
)
645 return -max_of_size (size
) - 1;
648 /* Maximum value of a SIZE-byte unsigned integer type. */
650 umax_of_size (int size
)
652 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
653 return top_bit
| (top_bit
- 1);
656 /* Maximum value of integral type T, as a signed quantity. */
658 max_of_type (struct type
*t
)
660 if (TYPE_UNSIGNED (t
))
661 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
663 return max_of_size (TYPE_LENGTH (t
));
666 /* Minimum value of integral type T, as a signed quantity. */
668 min_of_type (struct type
*t
)
670 if (TYPE_UNSIGNED (t
))
673 return min_of_size (TYPE_LENGTH (t
));
676 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
677 static struct value
*
678 discrete_type_high_bound (struct type
*type
)
680 switch (TYPE_CODE (type
))
682 case TYPE_CODE_RANGE
:
683 return value_from_longest (TYPE_TARGET_TYPE (type
),
684 TYPE_HIGH_BOUND (type
));
687 value_from_longest (type
,
688 TYPE_FIELD_BITPOS (type
,
689 TYPE_NFIELDS (type
) - 1));
691 return value_from_longest (type
, max_of_type (type
));
693 error ("Unexpected type in discrete_type_high_bound.");
697 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
698 static struct value
*
699 discrete_type_low_bound (struct type
*type
)
701 switch (TYPE_CODE (type
))
703 case TYPE_CODE_RANGE
:
704 return value_from_longest (TYPE_TARGET_TYPE (type
),
705 TYPE_LOW_BOUND (type
));
707 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
709 return value_from_longest (type
, min_of_type (type
));
711 error ("Unexpected type in discrete_type_low_bound.");
715 /* The identity on non-range types. For range types, the underlying
716 non-range scalar type. */
719 base_type (struct type
*type
)
721 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
723 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
725 type
= TYPE_TARGET_TYPE (type
);
731 /* Language Selection */
733 /* If the main program is in Ada, return language_ada, otherwise return LANG
734 (the main program is in Ada iif the adainit symbol is found).
736 MAIN_PST is not used. */
739 ada_update_initial_language (enum language lang
,
740 struct partial_symtab
*main_pst
)
742 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
743 (struct objfile
*) NULL
) != NULL
)
749 /* If the main procedure is written in Ada, then return its name.
750 The result is good until the next call. Return NULL if the main
751 procedure doesn't appear to be in Ada. */
756 struct minimal_symbol
*msym
;
757 CORE_ADDR main_program_name_addr
;
758 static char main_program_name
[1024];
760 /* For Ada, the name of the main procedure is stored in a specific
761 string constant, generated by the binder. Look for that symbol,
762 extract its address, and then read that string. If we didn't find
763 that string, then most probably the main procedure is not written
765 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
769 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
770 if (main_program_name_addr
== 0)
771 error ("Invalid address for Ada main program name.");
773 extract_string (main_program_name_addr
, main_program_name
);
774 return main_program_name
;
777 /* The main procedure doesn't seem to be in Ada. */
783 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
786 const struct ada_opname_map ada_opname_table
[] = {
787 {"Oadd", "\"+\"", BINOP_ADD
},
788 {"Osubtract", "\"-\"", BINOP_SUB
},
789 {"Omultiply", "\"*\"", BINOP_MUL
},
790 {"Odivide", "\"/\"", BINOP_DIV
},
791 {"Omod", "\"mod\"", BINOP_MOD
},
792 {"Orem", "\"rem\"", BINOP_REM
},
793 {"Oexpon", "\"**\"", BINOP_EXP
},
794 {"Olt", "\"<\"", BINOP_LESS
},
795 {"Ole", "\"<=\"", BINOP_LEQ
},
796 {"Ogt", "\">\"", BINOP_GTR
},
797 {"Oge", "\">=\"", BINOP_GEQ
},
798 {"Oeq", "\"=\"", BINOP_EQUAL
},
799 {"One", "\"/=\"", BINOP_NOTEQUAL
},
800 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
801 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
802 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
803 {"Oconcat", "\"&\"", BINOP_CONCAT
},
804 {"Oabs", "\"abs\"", UNOP_ABS
},
805 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
806 {"Oadd", "\"+\"", UNOP_PLUS
},
807 {"Osubtract", "\"-\"", UNOP_NEG
},
811 /* Return non-zero if STR should be suppressed in info listings. */
814 is_suppressed_name (const char *str
)
816 if (strncmp (str
, "_ada_", 5) == 0)
818 if (str
[0] == '_' || str
[0] == '\000')
823 const char *suffix
= strstr (str
, "___");
824 if (suffix
!= NULL
&& suffix
[3] != 'X')
827 suffix
= str
+ strlen (str
);
828 for (p
= suffix
- 1; p
!= str
; p
-= 1)
832 if (p
[0] == 'X' && p
[-1] != '_')
836 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
837 if (strncmp (ada_opname_table
[i
].encoded
, p
,
838 strlen (ada_opname_table
[i
].encoded
)) == 0)
847 /* The "encoded" form of DECODED, according to GNAT conventions.
848 The result is valid until the next call to ada_encode. */
851 ada_encode (const char *decoded
)
853 static char *encoding_buffer
= NULL
;
854 static size_t encoding_buffer_size
= 0;
861 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
862 2 * strlen (decoded
) + 10);
865 for (p
= decoded
; *p
!= '\0'; p
+= 1)
867 if (!ADA_RETAIN_DOTS
&& *p
== '.')
869 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
874 const struct ada_opname_map
*mapping
;
876 for (mapping
= ada_opname_table
;
877 mapping
->encoded
!= NULL
878 && strncmp (mapping
->decoded
, p
,
879 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
881 if (mapping
->encoded
== NULL
)
882 error ("invalid Ada operator name: %s", p
);
883 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
884 k
+= strlen (mapping
->encoded
);
889 encoding_buffer
[k
] = *p
;
894 encoding_buffer
[k
] = '\0';
895 return encoding_buffer
;
898 /* Return NAME folded to lower case, or, if surrounded by single
899 quotes, unfolded, but with the quotes stripped away. Result good
903 ada_fold_name (const char *name
)
905 static char *fold_buffer
= NULL
;
906 static size_t fold_buffer_size
= 0;
908 int len
= strlen (name
);
909 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
913 strncpy (fold_buffer
, name
+ 1, len
- 2);
914 fold_buffer
[len
- 2] = '\000';
919 for (i
= 0; i
<= len
; i
+= 1)
920 fold_buffer
[i
] = tolower (name
[i
]);
927 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
928 These are suffixes introduced by GNAT5 to nested subprogram
929 names, and do not serve any purpose for the debugger.
930 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
931 2. Convert other instances of embedded "__" to `.'.
932 3. Discard leading _ada_.
933 4. Convert operator names to the appropriate quoted symbols.
934 5. Remove everything after first ___ if it is followed by
936 6. Replace TK__ with __, and a trailing B or TKB with nothing.
937 7. Put symbols that should be suppressed in <...> brackets.
938 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
940 The resulting string is valid until the next call of ada_decode.
941 If the string is unchanged by demangling, the original string pointer
945 ada_decode (const char *encoded
)
952 static char *decoding_buffer
= NULL
;
953 static size_t decoding_buffer_size
= 0;
955 if (strncmp (encoded
, "_ada_", 5) == 0)
958 if (encoded
[0] == '_' || encoded
[0] == '<')
961 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
962 len0
= strlen (encoded
);
963 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
966 while (i
> 0 && isdigit (encoded
[i
]))
968 if (i
>= 0 && encoded
[i
] == '.')
970 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
974 /* Remove the ___X.* suffix if present. Do not forget to verify that
975 the suffix is located before the current "end" of ENCODED. We want
976 to avoid re-matching parts of ENCODED that have previously been
977 marked as discarded (by decrementing LEN0). */
978 p
= strstr (encoded
, "___");
979 if (p
!= NULL
&& p
- encoded
< len0
- 3)
987 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
990 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
993 /* Make decoded big enough for possible expansion by operator name. */
994 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
995 decoded
= decoding_buffer
;
997 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
1000 while ((i
>= 0 && isdigit (encoded
[i
]))
1001 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
1003 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
1005 else if (encoded
[i
] == '$')
1009 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
1010 decoded
[j
] = encoded
[i
];
1015 if (at_start_name
&& encoded
[i
] == 'O')
1018 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
1020 int op_len
= strlen (ada_opname_table
[k
].encoded
);
1021 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
1023 && !isalnum (encoded
[i
+ op_len
]))
1025 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1028 j
+= strlen (ada_opname_table
[k
].decoded
);
1032 if (ada_opname_table
[k
].encoded
!= NULL
)
1037 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1039 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1043 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1047 else if (!ADA_RETAIN_DOTS
1048 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1057 decoded
[j
] = encoded
[i
];
1062 decoded
[j
] = '\000';
1064 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1065 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1068 if (strcmp (decoded
, encoded
) == 0)
1074 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1075 decoded
= decoding_buffer
;
1076 if (encoded
[0] == '<')
1077 strcpy (decoded
, encoded
);
1079 sprintf (decoded
, "<%s>", encoded
);
1084 /* Table for keeping permanent unique copies of decoded names. Once
1085 allocated, names in this table are never released. While this is a
1086 storage leak, it should not be significant unless there are massive
1087 changes in the set of decoded names in successive versions of a
1088 symbol table loaded during a single session. */
1089 static struct htab
*decoded_names_store
;
1091 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1092 in the language-specific part of GSYMBOL, if it has not been
1093 previously computed. Tries to save the decoded name in the same
1094 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1095 in any case, the decoded symbol has a lifetime at least that of
1097 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1098 const, but nevertheless modified to a semantically equivalent form
1099 when a decoded name is cached in it.
1103 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1106 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1107 if (*resultp
== NULL
)
1109 const char *decoded
= ada_decode (gsymbol
->name
);
1110 if (gsymbol
->bfd_section
!= NULL
)
1112 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
1115 struct objfile
*objf
;
1118 if (obfd
== objf
->obfd
)
1120 *resultp
= obsavestring (decoded
, strlen (decoded
),
1121 &objf
->objfile_obstack
);
1127 /* Sometimes, we can't find a corresponding objfile, in which
1128 case, we put the result on the heap. Since we only decode
1129 when needed, we hope this usually does not cause a
1130 significant memory leak (FIXME). */
1131 if (*resultp
== NULL
)
1133 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1136 *slot
= xstrdup (decoded
);
1145 ada_la_decode (const char *encoded
, int options
)
1147 return xstrdup (ada_decode (encoded
));
1150 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1151 suffixes that encode debugging information or leading _ada_ on
1152 SYM_NAME (see is_name_suffix commentary for the debugging
1153 information that is ignored). If WILD, then NAME need only match a
1154 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1155 either argument is NULL. */
1158 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1160 if (sym_name
== NULL
|| name
== NULL
)
1163 return wild_match (name
, strlen (name
), sym_name
);
1166 int len_name
= strlen (name
);
1167 return (strncmp (sym_name
, name
, len_name
) == 0
1168 && is_name_suffix (sym_name
+ len_name
))
1169 || (strncmp (sym_name
, "_ada_", 5) == 0
1170 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1171 && is_name_suffix (sym_name
+ len_name
+ 5));
1175 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1176 suppressed in info listings. */
1179 ada_suppress_symbol_printing (struct symbol
*sym
)
1181 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1184 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1190 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1192 static char *bound_name
[] = {
1193 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1194 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1197 /* Maximum number of array dimensions we are prepared to handle. */
1199 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1201 /* Like modify_field, but allows bitpos > wordlength. */
1204 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1206 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1210 /* The desc_* routines return primitive portions of array descriptors
1213 /* The descriptor or array type, if any, indicated by TYPE; removes
1214 level of indirection, if needed. */
1216 static struct type
*
1217 desc_base_type (struct type
*type
)
1221 CHECK_TYPEDEF (type
);
1223 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1224 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1225 return check_typedef (TYPE_TARGET_TYPE (type
));
1230 /* True iff TYPE indicates a "thin" array pointer type. */
1233 is_thin_pntr (struct type
*type
)
1236 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1237 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1240 /* The descriptor type for thin pointer type TYPE. */
1242 static struct type
*
1243 thin_descriptor_type (struct type
*type
)
1245 struct type
*base_type
= desc_base_type (type
);
1246 if (base_type
== NULL
)
1248 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1252 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1253 if (alt_type
== NULL
)
1260 /* A pointer to the array data for thin-pointer value VAL. */
1262 static struct value
*
1263 thin_data_pntr (struct value
*val
)
1265 struct type
*type
= VALUE_TYPE (val
);
1266 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1267 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1270 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1271 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
1274 /* True iff TYPE indicates a "thick" array pointer type. */
1277 is_thick_pntr (struct type
*type
)
1279 type
= desc_base_type (type
);
1280 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1281 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1284 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1285 pointer to one, the type of its bounds data; otherwise, NULL. */
1287 static struct type
*
1288 desc_bounds_type (struct type
*type
)
1292 type
= desc_base_type (type
);
1296 else if (is_thin_pntr (type
))
1298 type
= thin_descriptor_type (type
);
1301 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1303 return check_typedef (r
);
1305 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1307 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1309 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r
)));
1314 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1315 one, a pointer to its bounds data. Otherwise NULL. */
1317 static struct value
*
1318 desc_bounds (struct value
*arr
)
1320 struct type
*type
= check_typedef (VALUE_TYPE (arr
));
1321 if (is_thin_pntr (type
))
1323 struct type
*bounds_type
=
1324 desc_bounds_type (thin_descriptor_type (type
));
1327 if (desc_bounds_type
== NULL
)
1328 error ("Bad GNAT array descriptor");
1330 /* NOTE: The following calculation is not really kosher, but
1331 since desc_type is an XVE-encoded type (and shouldn't be),
1332 the correct calculation is a real pain. FIXME (and fix GCC). */
1333 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1334 addr
= value_as_long (arr
);
1336 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
1339 value_from_longest (lookup_pointer_type (bounds_type
),
1340 addr
- TYPE_LENGTH (bounds_type
));
1343 else if (is_thick_pntr (type
))
1344 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1345 "Bad GNAT array descriptor");
1350 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1351 position of the field containing the address of the bounds data. */
1354 fat_pntr_bounds_bitpos (struct type
*type
)
1356 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1359 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1360 size of the field containing the address of the bounds data. */
1363 fat_pntr_bounds_bitsize (struct type
*type
)
1365 type
= desc_base_type (type
);
1367 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1368 return TYPE_FIELD_BITSIZE (type
, 1);
1370 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1373 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1374 pointer to one, the type of its array data (a
1375 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1376 ada_type_of_array to get an array type with bounds data. */
1378 static struct type
*
1379 desc_data_type (struct type
*type
)
1381 type
= desc_base_type (type
);
1383 /* NOTE: The following is bogus; see comment in desc_bounds. */
1384 if (is_thin_pntr (type
))
1385 return lookup_pointer_type
1386 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1387 else if (is_thick_pntr (type
))
1388 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1393 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1396 static struct value
*
1397 desc_data (struct value
*arr
)
1399 struct type
*type
= VALUE_TYPE (arr
);
1400 if (is_thin_pntr (type
))
1401 return thin_data_pntr (arr
);
1402 else if (is_thick_pntr (type
))
1403 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1404 "Bad GNAT array descriptor");
1410 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1411 position of the field containing the address of the data. */
1414 fat_pntr_data_bitpos (struct type
*type
)
1416 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1419 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1420 size of the field containing the address of the data. */
1423 fat_pntr_data_bitsize (struct type
*type
)
1425 type
= desc_base_type (type
);
1427 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1428 return TYPE_FIELD_BITSIZE (type
, 0);
1430 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1433 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1434 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1435 bound, if WHICH is 1. The first bound is I=1. */
1437 static struct value
*
1438 desc_one_bound (struct value
*bounds
, int i
, int which
)
1440 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1441 "Bad GNAT array descriptor bounds");
1444 /* If BOUNDS is an array-bounds structure type, return the bit position
1445 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1446 bound, if WHICH is 1. The first bound is I=1. */
1449 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1451 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1454 /* If BOUNDS is an array-bounds structure type, return the bit field size
1455 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1456 bound, if WHICH is 1. The first bound is I=1. */
1459 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1461 type
= desc_base_type (type
);
1463 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1464 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1466 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1469 /* If TYPE is the type of an array-bounds structure, the type of its
1470 Ith bound (numbering from 1). Otherwise, NULL. */
1472 static struct type
*
1473 desc_index_type (struct type
*type
, int i
)
1475 type
= desc_base_type (type
);
1477 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1478 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1483 /* The number of index positions in the array-bounds type TYPE.
1484 Return 0 if TYPE is NULL. */
1487 desc_arity (struct type
*type
)
1489 type
= desc_base_type (type
);
1492 return TYPE_NFIELDS (type
) / 2;
1496 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1497 an array descriptor type (representing an unconstrained array
1501 ada_is_direct_array_type (struct type
*type
)
1505 CHECK_TYPEDEF (type
);
1506 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1507 || ada_is_array_descriptor_type (type
));
1510 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1513 ada_is_simple_array_type (struct type
*type
)
1517 CHECK_TYPEDEF (type
);
1518 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1519 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1520 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1523 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1526 ada_is_array_descriptor_type (struct type
*type
)
1528 struct type
*data_type
= desc_data_type (type
);
1532 CHECK_TYPEDEF (type
);
1535 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1536 && TYPE_TARGET_TYPE (data_type
) != NULL
1537 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1538 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1539 && desc_arity (desc_bounds_type (type
)) > 0;
1542 /* Non-zero iff type is a partially mal-formed GNAT array
1543 descriptor. FIXME: This is to compensate for some problems with
1544 debugging output from GNAT. Re-examine periodically to see if it
1548 ada_is_bogus_array_descriptor (struct type
*type
)
1552 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1553 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1554 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1555 && !ada_is_array_descriptor_type (type
);
1559 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1560 (fat pointer) returns the type of the array data described---specifically,
1561 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1562 in from the descriptor; otherwise, they are left unspecified. If
1563 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1564 returns NULL. The result is simply the type of ARR if ARR is not
1567 ada_type_of_array (struct value
*arr
, int bounds
)
1569 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1570 return decode_packed_array_type (VALUE_TYPE (arr
));
1572 if (!ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1573 return VALUE_TYPE (arr
);
1577 check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1580 struct type
*elt_type
;
1582 struct value
*descriptor
;
1583 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1585 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1586 arity
= ada_array_arity (VALUE_TYPE (arr
));
1588 if (elt_type
== NULL
|| arity
== 0)
1589 return check_typedef (VALUE_TYPE (arr
));
1591 descriptor
= desc_bounds (arr
);
1592 if (value_as_long (descriptor
) == 0)
1596 struct type
*range_type
= alloc_type (objf
);
1597 struct type
*array_type
= alloc_type (objf
);
1598 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1599 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1602 create_range_type (range_type
, VALUE_TYPE (low
),
1603 (int) value_as_long (low
),
1604 (int) value_as_long (high
));
1605 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1608 return lookup_pointer_type (elt_type
);
1612 /* If ARR does not represent an array, returns ARR unchanged.
1613 Otherwise, returns either a standard GDB array with bounds set
1614 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1615 GDB array. Returns NULL if ARR is a null fat pointer. */
1618 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1620 if (ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1622 struct type
*arrType
= ada_type_of_array (arr
, 1);
1623 if (arrType
== NULL
)
1625 return value_cast (arrType
, value_copy (desc_data (arr
)));
1627 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1628 return decode_packed_array (arr
);
1633 /* If ARR does not represent an array, returns ARR unchanged.
1634 Otherwise, returns a standard GDB array describing ARR (which may
1635 be ARR itself if it already is in the proper form). */
1637 static struct value
*
1638 ada_coerce_to_simple_array (struct value
*arr
)
1640 if (ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1642 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1644 error ("Bounds unavailable for null array pointer.");
1645 return value_ind (arrVal
);
1647 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1648 return decode_packed_array (arr
);
1653 /* If TYPE represents a GNAT array type, return it translated to an
1654 ordinary GDB array type (possibly with BITSIZE fields indicating
1655 packing). For other types, is the identity. */
1658 ada_coerce_to_simple_array_type (struct type
*type
)
1660 struct value
*mark
= value_mark ();
1661 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1662 struct type
*result
;
1663 VALUE_TYPE (dummy
) = type
;
1664 result
= ada_type_of_array (dummy
, 0);
1665 value_free_to_mark (mark
);
1669 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1672 ada_is_packed_array_type (struct type
*type
)
1676 type
= desc_base_type (type
);
1677 CHECK_TYPEDEF (type
);
1679 ada_type_name (type
) != NULL
1680 && strstr (ada_type_name (type
), "___XP") != NULL
;
1683 /* Given that TYPE is a standard GDB array type with all bounds filled
1684 in, and that the element size of its ultimate scalar constituents
1685 (that is, either its elements, or, if it is an array of arrays, its
1686 elements' elements, etc.) is *ELT_BITS, return an identical type,
1687 but with the bit sizes of its elements (and those of any
1688 constituent arrays) recorded in the BITSIZE components of its
1689 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1692 static struct type
*
1693 packed_array_type (struct type
*type
, long *elt_bits
)
1695 struct type
*new_elt_type
;
1696 struct type
*new_type
;
1697 LONGEST low_bound
, high_bound
;
1699 CHECK_TYPEDEF (type
);
1700 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1703 new_type
= alloc_type (TYPE_OBJFILE (type
));
1704 new_elt_type
= packed_array_type (check_typedef (TYPE_TARGET_TYPE (type
)),
1706 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1707 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1708 TYPE_NAME (new_type
) = ada_type_name (type
);
1710 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1711 &low_bound
, &high_bound
) < 0)
1712 low_bound
= high_bound
= 0;
1713 if (high_bound
< low_bound
)
1714 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1717 *elt_bits
*= (high_bound
- low_bound
+ 1);
1718 TYPE_LENGTH (new_type
) =
1719 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1722 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1726 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1728 static struct type
*
1729 decode_packed_array_type (struct type
*type
)
1732 struct block
**blocks
;
1733 const char *raw_name
= ada_type_name (check_typedef (type
));
1734 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1735 char *tail
= strstr (raw_name
, "___XP");
1736 struct type
*shadow_type
;
1740 type
= desc_base_type (type
);
1742 memcpy (name
, raw_name
, tail
- raw_name
);
1743 name
[tail
- raw_name
] = '\000';
1745 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1746 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1748 lim_warning ("could not find bounds information on packed array", 0);
1751 shadow_type
= SYMBOL_TYPE (sym
);
1753 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1755 lim_warning ("could not understand bounds information on packed array",
1760 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1763 ("could not understand bit size information on packed array", 0);
1767 return packed_array_type (shadow_type
, &bits
);
1770 /* Given that ARR is a struct value *indicating a GNAT packed array,
1771 returns a simple array that denotes that array. Its type is a
1772 standard GDB array type except that the BITSIZEs of the array
1773 target types are set to the number of bits in each element, and the
1774 type length is set appropriately. */
1776 static struct value
*
1777 decode_packed_array (struct value
*arr
)
1781 arr
= ada_coerce_ref (arr
);
1782 if (TYPE_CODE (VALUE_TYPE (arr
)) == TYPE_CODE_PTR
)
1783 arr
= ada_value_ind (arr
);
1785 type
= decode_packed_array_type (VALUE_TYPE (arr
));
1788 error ("can't unpack array");
1791 return coerce_unspec_val_to_type (arr
, type
);
1795 /* The value of the element of packed array ARR at the ARITY indices
1796 given in IND. ARR must be a simple array. */
1798 static struct value
*
1799 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1802 int bits
, elt_off
, bit_off
;
1803 long elt_total_bit_offset
;
1804 struct type
*elt_type
;
1808 elt_total_bit_offset
= 0;
1809 elt_type
= check_typedef (VALUE_TYPE (arr
));
1810 for (i
= 0; i
< arity
; i
+= 1)
1812 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1813 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1815 ("attempt to do packed indexing of something other than a packed array");
1818 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1819 LONGEST lowerbound
, upperbound
;
1822 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1824 lim_warning ("don't know bounds of array", 0);
1825 lowerbound
= upperbound
= 0;
1828 idx
= value_as_long (value_pos_atr (ind
[i
]));
1829 if (idx
< lowerbound
|| idx
> upperbound
)
1830 lim_warning ("packed array index %ld out of bounds", (long) idx
);
1831 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1832 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1833 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
1836 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1837 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1839 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1841 if (VALUE_LVAL (arr
) == lval_internalvar
)
1842 VALUE_LVAL (v
) = lval_internalvar_component
;
1844 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1848 /* Non-zero iff TYPE includes negative integer values. */
1851 has_negatives (struct type
*type
)
1853 switch (TYPE_CODE (type
))
1858 return !TYPE_UNSIGNED (type
);
1859 case TYPE_CODE_RANGE
:
1860 return TYPE_LOW_BOUND (type
) < 0;
1865 /* Create a new value of type TYPE from the contents of OBJ starting
1866 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1867 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1868 assigning through the result will set the field fetched from.
1869 VALADDR is ignored unless OBJ is NULL, in which case,
1870 VALADDR+OFFSET must address the start of storage containing the
1871 packed value. The value returned in this case is never an lval.
1872 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1875 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1876 int bit_offset
, int bit_size
,
1880 int src
, /* Index into the source area */
1881 targ
, /* Index into the target area */
1882 srcBitsLeft
, /* Number of source bits left to move */
1883 nsrc
, ntarg
, /* Number of source and target bytes */
1884 unusedLS
, /* Number of bits in next significant
1885 byte of source that are unused */
1886 accumSize
; /* Number of meaningful bits in accum */
1887 unsigned char *bytes
; /* First byte containing data to unpack */
1888 unsigned char *unpacked
;
1889 unsigned long accum
; /* Staging area for bits being transferred */
1891 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1892 /* Transmit bytes from least to most significant; delta is the direction
1893 the indices move. */
1894 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1896 CHECK_TYPEDEF (type
);
1900 v
= allocate_value (type
);
1901 bytes
= (unsigned char *) (valaddr
+ offset
);
1903 else if (VALUE_LAZY (obj
))
1906 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1907 bytes
= (unsigned char *) alloca (len
);
1908 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1912 v
= allocate_value (type
);
1913 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1918 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1919 if (VALUE_LVAL (obj
) == lval_internalvar
)
1920 VALUE_LVAL (v
) = lval_internalvar_component
;
1921 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1922 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1923 VALUE_BITSIZE (v
) = bit_size
;
1924 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1926 VALUE_ADDRESS (v
) += 1;
1927 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1931 VALUE_BITSIZE (v
) = bit_size
;
1932 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1934 srcBitsLeft
= bit_size
;
1936 ntarg
= TYPE_LENGTH (type
);
1940 memset (unpacked
, 0, TYPE_LENGTH (type
));
1943 else if (BITS_BIG_ENDIAN
)
1946 if (has_negatives (type
)
1947 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1951 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1954 switch (TYPE_CODE (type
))
1956 case TYPE_CODE_ARRAY
:
1957 case TYPE_CODE_UNION
:
1958 case TYPE_CODE_STRUCT
:
1959 /* Non-scalar values must be aligned at a byte boundary... */
1961 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1962 /* ... And are placed at the beginning (most-significant) bytes
1968 targ
= TYPE_LENGTH (type
) - 1;
1974 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1977 unusedLS
= bit_offset
;
1980 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1987 /* Mask for removing bits of the next source byte that are not
1988 part of the value. */
1989 unsigned int unusedMSMask
=
1990 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1992 /* Sign-extend bits for this byte. */
1993 unsigned int signMask
= sign
& ~unusedMSMask
;
1995 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1996 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1997 if (accumSize
>= HOST_CHAR_BIT
)
1999 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2000 accumSize
-= HOST_CHAR_BIT
;
2001 accum
>>= HOST_CHAR_BIT
;
2005 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2012 accum
|= sign
<< accumSize
;
2013 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2014 accumSize
-= HOST_CHAR_BIT
;
2015 accum
>>= HOST_CHAR_BIT
;
2023 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2024 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2027 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
2029 unsigned int accum
, mask
;
2030 int accum_bits
, chunk_size
;
2032 target
+= targ_offset
/ HOST_CHAR_BIT
;
2033 targ_offset
%= HOST_CHAR_BIT
;
2034 source
+= src_offset
/ HOST_CHAR_BIT
;
2035 src_offset
%= HOST_CHAR_BIT
;
2036 if (BITS_BIG_ENDIAN
)
2038 accum
= (unsigned char) *source
;
2040 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2045 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2046 accum_bits
+= HOST_CHAR_BIT
;
2048 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2051 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2052 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2055 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2057 accum_bits
-= chunk_size
;
2064 accum
= (unsigned char) *source
>> src_offset
;
2066 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2070 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2071 accum_bits
+= HOST_CHAR_BIT
;
2073 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2076 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2077 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2079 accum_bits
-= chunk_size
;
2080 accum
>>= chunk_size
;
2088 /* Store the contents of FROMVAL into the location of TOVAL.
2089 Return a new value with the location of TOVAL and contents of
2090 FROMVAL. Handles assignment into packed fields that have
2091 floating-point or non-scalar types. */
2093 static struct value
*
2094 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2096 struct type
*type
= VALUE_TYPE (toval
);
2097 int bits
= VALUE_BITSIZE (toval
);
2099 if (!toval
->modifiable
)
2100 error ("Left operand of assignment is not a modifiable lvalue.");
2104 if (VALUE_LVAL (toval
) == lval_memory
2106 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2107 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2110 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2111 char *buffer
= (char *) alloca (len
);
2114 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2115 fromval
= value_cast (type
, fromval
);
2117 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
2118 if (BITS_BIG_ENDIAN
)
2119 move_bits (buffer
, VALUE_BITPOS (toval
),
2120 VALUE_CONTENTS (fromval
),
2121 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
-
2124 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
2126 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
,
2129 val
= value_copy (toval
);
2130 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
2131 TYPE_LENGTH (type
));
2132 VALUE_TYPE (val
) = type
;
2137 return value_assign (toval
, fromval
);
2141 /* The value of the element of array ARR at the ARITY indices given in IND.
2142 ARR may be either a simple array, GNAT array descriptor, or pointer
2146 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2150 struct type
*elt_type
;
2152 elt
= ada_coerce_to_simple_array (arr
);
2154 elt_type
= check_typedef (VALUE_TYPE (elt
));
2155 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2156 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2157 return value_subscript_packed (elt
, arity
, ind
);
2159 for (k
= 0; k
< arity
; k
+= 1)
2161 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2162 error ("too many subscripts (%d expected)", k
);
2163 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2168 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2169 value of the element of *ARR at the ARITY indices given in
2170 IND. Does not read the entire array into memory. */
2173 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2178 for (k
= 0; k
< arity
; k
+= 1)
2183 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2184 error ("too many subscripts (%d expected)", k
);
2185 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2187 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2188 idx
= value_pos_atr (ind
[k
]);
2190 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2191 arr
= value_add (arr
, idx
);
2192 type
= TYPE_TARGET_TYPE (type
);
2195 return value_ind (arr
);
2198 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2199 actual type of ARRAY_PTR is ignored), returns a reference to
2200 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2201 bound of this array is LOW, as per Ada rules. */
2202 static struct value
*
2203 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2206 CORE_ADDR base
= value_as_address (array_ptr
)
2207 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2208 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2209 struct type
*index_type
=
2210 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2212 struct type
*slice_type
=
2213 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2214 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2218 static struct value
*
2219 ada_value_slice (struct value
*array
, int low
, int high
)
2221 struct type
*type
= VALUE_TYPE (array
);
2222 struct type
*index_type
=
2223 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2224 struct type
*slice_type
=
2225 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2226 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2229 /* If type is a record type in the form of a standard GNAT array
2230 descriptor, returns the number of dimensions for type. If arr is a
2231 simple array, returns the number of "array of"s that prefix its
2232 type designation. Otherwise, returns 0. */
2235 ada_array_arity (struct type
*type
)
2242 type
= desc_base_type (type
);
2245 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2246 return desc_arity (desc_bounds_type (type
));
2248 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2251 type
= check_typedef (TYPE_TARGET_TYPE (type
));
2257 /* If TYPE is a record type in the form of a standard GNAT array
2258 descriptor or a simple array type, returns the element type for
2259 TYPE after indexing by NINDICES indices, or by all indices if
2260 NINDICES is -1. Otherwise, returns NULL. */
2263 ada_array_element_type (struct type
*type
, int nindices
)
2265 type
= desc_base_type (type
);
2267 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2270 struct type
*p_array_type
;
2272 p_array_type
= desc_data_type (type
);
2274 k
= ada_array_arity (type
);
2278 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2279 if (nindices
>= 0 && k
> nindices
)
2281 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2282 while (k
> 0 && p_array_type
!= NULL
)
2284 p_array_type
= check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2287 return p_array_type
;
2289 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2291 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2293 type
= TYPE_TARGET_TYPE (type
);
2302 /* The type of nth index in arrays of given type (n numbering from 1).
2303 Does not examine memory. */
2306 ada_index_type (struct type
*type
, int n
)
2308 struct type
*result_type
;
2310 type
= desc_base_type (type
);
2312 if (n
> ada_array_arity (type
))
2315 if (ada_is_simple_array_type (type
))
2319 for (i
= 1; i
< n
; i
+= 1)
2320 type
= TYPE_TARGET_TYPE (type
);
2321 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2322 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2323 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2324 perhaps stabsread.c would make more sense. */
2325 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2326 result_type
= builtin_type_int
;
2331 return desc_index_type (desc_bounds_type (type
), n
);
2334 /* Given that arr is an array type, returns the lower bound of the
2335 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2336 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2337 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2338 bounds type. It works for other arrays with bounds supplied by
2339 run-time quantities other than discriminants. */
2342 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2343 struct type
** typep
)
2346 struct type
*index_type_desc
;
2348 if (ada_is_packed_array_type (arr_type
))
2349 arr_type
= decode_packed_array_type (arr_type
);
2351 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2354 *typep
= builtin_type_int
;
2355 return (LONGEST
) - which
;
2358 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2359 type
= TYPE_TARGET_TYPE (arr_type
);
2363 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2364 if (index_type_desc
== NULL
)
2366 struct type
*range_type
;
2367 struct type
*index_type
;
2371 type
= TYPE_TARGET_TYPE (type
);
2375 range_type
= TYPE_INDEX_TYPE (type
);
2376 index_type
= TYPE_TARGET_TYPE (range_type
);
2377 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2378 index_type
= builtin_type_long
;
2380 *typep
= index_type
;
2382 (LONGEST
) (which
== 0
2383 ? TYPE_LOW_BOUND (range_type
)
2384 : TYPE_HIGH_BOUND (range_type
));
2388 struct type
*index_type
=
2389 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2390 NULL
, TYPE_OBJFILE (arr_type
));
2392 *typep
= TYPE_TARGET_TYPE (index_type
);
2394 (LONGEST
) (which
== 0
2395 ? TYPE_LOW_BOUND (index_type
)
2396 : TYPE_HIGH_BOUND (index_type
));
2400 /* Given that arr is an array value, returns the lower bound of the
2401 nth index (numbering from 1) if which is 0, and the upper bound if
2402 which is 1. This routine will also work for arrays with bounds
2403 supplied by run-time quantities other than discriminants. */
2406 ada_array_bound (struct value
*arr
, int n
, int which
)
2408 struct type
*arr_type
= VALUE_TYPE (arr
);
2410 if (ada_is_packed_array_type (arr_type
))
2411 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2412 else if (ada_is_simple_array_type (arr_type
))
2415 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2416 return value_from_longest (type
, v
);
2419 return desc_one_bound (desc_bounds (arr
), n
, which
);
2422 /* Given that arr is an array value, returns the length of the
2423 nth index. This routine will also work for arrays with bounds
2424 supplied by run-time quantities other than discriminants.
2425 Does not work for arrays indexed by enumeration types with representation
2426 clauses at the moment. */
2429 ada_array_length (struct value
*arr
, int n
)
2431 struct type
*arr_type
= check_typedef (VALUE_TYPE (arr
));
2433 if (ada_is_packed_array_type (arr_type
))
2434 return ada_array_length (decode_packed_array (arr
), n
);
2436 if (ada_is_simple_array_type (arr_type
))
2440 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2441 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2442 return value_from_longest (type
, v
);
2446 value_from_longest (builtin_type_int
,
2447 value_as_long (desc_one_bound (desc_bounds (arr
),
2449 - value_as_long (desc_one_bound (desc_bounds (arr
),
2453 /* An empty array whose type is that of ARR_TYPE (an array type),
2454 with bounds LOW to LOW-1. */
2456 static struct value
*
2457 empty_array (struct type
*arr_type
, int low
)
2459 struct type
*index_type
=
2460 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2462 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2463 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2467 /* Name resolution */
2469 /* The "decoded" name for the user-definable Ada operator corresponding
2473 ada_decoded_op_name (enum exp_opcode op
)
2477 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2479 if (ada_opname_table
[i
].op
== op
)
2480 return ada_opname_table
[i
].decoded
;
2482 error ("Could not find operator name for opcode");
2486 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2487 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2488 undefined namespace) and converts operators that are
2489 user-defined into appropriate function calls. If CONTEXT_TYPE is
2490 non-null, it provides a preferred result type [at the moment, only
2491 type void has any effect---causing procedures to be preferred over
2492 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2493 return type is preferred. May change (expand) *EXP. */
2496 resolve (struct expression
**expp
, int void_context_p
)
2500 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2503 /* Resolve the operator of the subexpression beginning at
2504 position *POS of *EXPP. "Resolving" consists of replacing
2505 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2506 with their resolutions, replacing built-in operators with
2507 function calls to user-defined operators, where appropriate, and,
2508 when DEPROCEDURE_P is non-zero, converting function-valued variables
2509 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2510 are as in ada_resolve, above. */
2512 static struct value
*
2513 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2514 struct type
*context_type
)
2518 struct expression
*exp
; /* Convenience: == *expp. */
2519 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2520 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2521 int nargs
; /* Number of operands. */
2527 /* Pass one: resolve operands, saving their types and updating *pos. */
2531 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2532 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2537 resolve_subexp (expp
, pos
, 0, NULL
);
2539 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2544 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2549 resolve_subexp (expp
, pos
, 0, NULL
);
2552 case OP_ATR_MODULUS
:
2582 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2584 resolve_subexp (expp
, pos
, 1, NULL
);
2586 resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2604 case BINOP_LOGICAL_AND
:
2605 case BINOP_LOGICAL_OR
:
2606 case BINOP_BITWISE_AND
:
2607 case BINOP_BITWISE_IOR
:
2608 case BINOP_BITWISE_XOR
:
2611 case BINOP_NOTEQUAL
:
2618 case BINOP_SUBSCRIPT
:
2626 case UNOP_LOGICAL_NOT
:
2643 case OP_INTERNALVAR
:
2652 case STRUCTOP_STRUCT
:
2653 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2659 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2664 case TERNOP_IN_RANGE
:
2669 case BINOP_IN_BOUNDS
:
2675 error ("Unexpected operator during name resolution");
2678 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2679 for (i
= 0; i
< nargs
; i
+= 1)
2680 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2684 /* Pass two: perform any resolution on principal operator. */
2691 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2693 struct ada_symbol_info
*candidates
;
2697 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2698 (exp
->elts
[pc
+ 2].symbol
),
2699 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2702 if (n_candidates
> 1)
2704 /* Types tend to get re-introduced locally, so if there
2705 are any local symbols that are not types, first filter
2708 for (j
= 0; j
< n_candidates
; j
+= 1)
2709 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2715 case LOC_REGPARM_ADDR
:
2719 case LOC_BASEREG_ARG
:
2721 case LOC_COMPUTED_ARG
:
2727 if (j
< n_candidates
)
2730 while (j
< n_candidates
)
2732 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2734 candidates
[j
] = candidates
[n_candidates
- 1];
2743 if (n_candidates
== 0)
2744 error ("No definition found for %s",
2745 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2746 else if (n_candidates
== 1)
2748 else if (deprocedure_p
2749 && !is_nonfunction (candidates
, n_candidates
))
2751 i
= ada_resolve_function
2752 (candidates
, n_candidates
, NULL
, 0,
2753 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2756 error ("Could not find a match for %s",
2757 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2761 printf_filtered ("Multiple matches for %s\n",
2762 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2763 user_select_syms (candidates
, n_candidates
, 1);
2767 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2768 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2769 if (innermost_block
== NULL
2770 || contained_in (candidates
[i
].block
, innermost_block
))
2771 innermost_block
= candidates
[i
].block
;
2775 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2778 replace_operator_with_call (expp
, pc
, 0, 0,
2779 exp
->elts
[pc
+ 2].symbol
,
2780 exp
->elts
[pc
+ 1].block
);
2787 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2788 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2790 struct ada_symbol_info
*candidates
;
2794 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2795 (exp
->elts
[pc
+ 5].symbol
),
2796 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2798 if (n_candidates
== 1)
2802 i
= ada_resolve_function
2803 (candidates
, n_candidates
,
2805 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2808 error ("Could not find a match for %s",
2809 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2812 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2813 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2814 if (innermost_block
== NULL
2815 || contained_in (candidates
[i
].block
, innermost_block
))
2816 innermost_block
= candidates
[i
].block
;
2827 case BINOP_BITWISE_AND
:
2828 case BINOP_BITWISE_IOR
:
2829 case BINOP_BITWISE_XOR
:
2831 case BINOP_NOTEQUAL
:
2839 case UNOP_LOGICAL_NOT
:
2841 if (possible_user_operator_p (op
, argvec
))
2843 struct ada_symbol_info
*candidates
;
2847 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2848 (struct block
*) NULL
, VAR_DOMAIN
,
2850 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2851 ada_decoded_op_name (op
), NULL
);
2855 replace_operator_with_call (expp
, pc
, nargs
, 1,
2856 candidates
[i
].sym
, candidates
[i
].block
);
2866 return evaluate_subexp_type (exp
, pos
);
2869 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2870 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2871 a non-pointer. A type of 'void' (which is never a valid expression type)
2872 by convention matches anything. */
2873 /* The term "match" here is rather loose. The match is heuristic and
2874 liberal. FIXME: TOO liberal, in fact. */
2877 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2879 CHECK_TYPEDEF (ftype
);
2880 CHECK_TYPEDEF (atype
);
2882 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2883 ftype
= TYPE_TARGET_TYPE (ftype
);
2884 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2885 atype
= TYPE_TARGET_TYPE (atype
);
2887 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2888 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2891 switch (TYPE_CODE (ftype
))
2896 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2897 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2898 TYPE_TARGET_TYPE (atype
), 0);
2901 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2903 case TYPE_CODE_ENUM
:
2904 case TYPE_CODE_RANGE
:
2905 switch (TYPE_CODE (atype
))
2908 case TYPE_CODE_ENUM
:
2909 case TYPE_CODE_RANGE
:
2915 case TYPE_CODE_ARRAY
:
2916 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2917 || ada_is_array_descriptor_type (atype
));
2919 case TYPE_CODE_STRUCT
:
2920 if (ada_is_array_descriptor_type (ftype
))
2921 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2922 || ada_is_array_descriptor_type (atype
));
2924 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2925 && !ada_is_array_descriptor_type (atype
));
2927 case TYPE_CODE_UNION
:
2929 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2933 /* Return non-zero if the formals of FUNC "sufficiently match" the
2934 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2935 may also be an enumeral, in which case it is treated as a 0-
2936 argument function. */
2939 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2942 struct type
*func_type
= SYMBOL_TYPE (func
);
2944 if (SYMBOL_CLASS (func
) == LOC_CONST
2945 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2946 return (n_actuals
== 0);
2947 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2950 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2953 for (i
= 0; i
< n_actuals
; i
+= 1)
2955 if (actuals
[i
] == NULL
)
2959 struct type
*ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2960 struct type
*atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2962 if (!ada_type_match (ftype
, atype
, 1))
2969 /* False iff function type FUNC_TYPE definitely does not produce a value
2970 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2971 FUNC_TYPE is not a valid function type with a non-null return type
2972 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2975 return_match (struct type
*func_type
, struct type
*context_type
)
2977 struct type
*return_type
;
2979 if (func_type
== NULL
)
2982 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2983 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2985 return_type
= base_type (func_type
);
2986 if (return_type
== NULL
)
2989 context_type
= base_type (context_type
);
2991 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2992 return context_type
== NULL
|| return_type
== context_type
;
2993 else if (context_type
== NULL
)
2994 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2996 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3000 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3001 function (if any) that matches the types of the NARGS arguments in
3002 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3003 that returns that type, then eliminate matches that don't. If
3004 CONTEXT_TYPE is void and there is at least one match that does not
3005 return void, eliminate all matches that do.
3007 Asks the user if there is more than one match remaining. Returns -1
3008 if there is no such symbol or none is selected. NAME is used
3009 solely for messages. May re-arrange and modify SYMS in
3010 the process; the index returned is for the modified vector. */
3013 ada_resolve_function (struct ada_symbol_info syms
[],
3014 int nsyms
, struct value
**args
, int nargs
,
3015 const char *name
, struct type
*context_type
)
3018 int m
; /* Number of hits */
3019 struct type
*fallback
;
3020 struct type
*return_type
;
3022 return_type
= context_type
;
3023 if (context_type
== NULL
)
3024 fallback
= builtin_type_void
;
3031 for (k
= 0; k
< nsyms
; k
+= 1)
3033 struct type
*type
= check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3035 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3036 && return_match (type
, return_type
))
3042 if (m
> 0 || return_type
== fallback
)
3045 return_type
= fallback
;
3052 printf_filtered ("Multiple matches for %s\n", name
);
3053 user_select_syms (syms
, m
, 1);
3059 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3060 in a listing of choices during disambiguation (see sort_choices, below).
3061 The idea is that overloadings of a subprogram name from the
3062 same package should sort in their source order. We settle for ordering
3063 such symbols by their trailing number (__N or $N). */
3066 encoded_ordered_before (char *N0
, char *N1
)
3070 else if (N0
== NULL
)
3075 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3077 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3079 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3080 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3084 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3087 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3089 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3090 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3092 return (strcmp (N0
, N1
) < 0);
3096 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3100 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3103 for (i
= 1; i
< nsyms
; i
+= 1)
3105 struct ada_symbol_info sym
= syms
[i
];
3108 for (j
= i
- 1; j
>= 0; j
-= 1)
3110 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3111 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3113 syms
[j
+ 1] = syms
[j
];
3119 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3120 by asking the user (if necessary), returning the number selected,
3121 and setting the first elements of SYMS items. Error if no symbols
3124 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3125 to be re-integrated one of these days. */
3128 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3131 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3133 int first_choice
= (max_results
== 1) ? 1 : 2;
3135 if (max_results
< 1)
3136 error ("Request to select 0 symbols!");
3140 printf_unfiltered ("[0] cancel\n");
3141 if (max_results
> 1)
3142 printf_unfiltered ("[1] all\n");
3144 sort_choices (syms
, nsyms
);
3146 for (i
= 0; i
< nsyms
; i
+= 1)
3148 if (syms
[i
].sym
== NULL
)
3151 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3153 struct symtab_and_line sal
=
3154 find_function_start_sal (syms
[i
].sym
, 1);
3155 printf_unfiltered ("[%d] %s at %s:%d\n", i
+ first_choice
,
3156 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3158 ? "<no source file available>"
3159 : sal
.symtab
->filename
), sal
.line
);
3165 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3166 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3167 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3168 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3170 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3171 printf_unfiltered ("[%d] %s at %s:%d\n",
3173 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3174 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3175 else if (is_enumeral
3176 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3178 printf_unfiltered ("[%d] ", i
+ first_choice
);
3179 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3181 printf_unfiltered ("'(%s) (enumeral)\n",
3182 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3184 else if (symtab
!= NULL
)
3185 printf_unfiltered (is_enumeral
3186 ? "[%d] %s in %s (enumeral)\n"
3187 : "[%d] %s at %s:?\n",
3189 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3192 printf_unfiltered (is_enumeral
3193 ? "[%d] %s (enumeral)\n"
3196 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3200 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3203 for (i
= 0; i
< n_chosen
; i
+= 1)
3204 syms
[i
] = syms
[chosen
[i
]];
3209 /* Read and validate a set of numeric choices from the user in the
3210 range 0 .. N_CHOICES-1. Place the results in increasing
3211 order in CHOICES[0 .. N-1], and return N.
3213 The user types choices as a sequence of numbers on one line
3214 separated by blanks, encoding them as follows:
3216 + A choice of 0 means to cancel the selection, throwing an error.
3217 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3218 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3220 The user is not allowed to choose more than MAX_RESULTS values.
3222 ANNOTATION_SUFFIX, if present, is used to annotate the input
3223 prompts (for use with the -f switch). */
3226 get_selections (int *choices
, int n_choices
, int max_results
,
3227 int is_all_choice
, char *annotation_suffix
)
3232 int first_choice
= is_all_choice
? 2 : 1;
3234 prompt
= getenv ("PS2");
3238 printf_unfiltered ("%s ", prompt
);
3239 gdb_flush (gdb_stdout
);
3241 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3244 error_no_arg ("one or more choice numbers");
3248 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3249 order, as given in args. Choices are validated. */
3255 while (isspace (*args
))
3257 if (*args
== '\0' && n_chosen
== 0)
3258 error_no_arg ("one or more choice numbers");
3259 else if (*args
== '\0')
3262 choice
= strtol (args
, &args2
, 10);
3263 if (args
== args2
|| choice
< 0
3264 || choice
> n_choices
+ first_choice
- 1)
3265 error ("Argument must be choice number");
3269 error ("cancelled");
3271 if (choice
< first_choice
)
3273 n_chosen
= n_choices
;
3274 for (j
= 0; j
< n_choices
; j
+= 1)
3278 choice
-= first_choice
;
3280 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3284 if (j
< 0 || choice
!= choices
[j
])
3287 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3288 choices
[k
+ 1] = choices
[k
];
3289 choices
[j
+ 1] = choice
;
3294 if (n_chosen
> max_results
)
3295 error ("Select no more than %d of the above", max_results
);
3300 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3301 on the function identified by SYM and BLOCK, and taking NARGS
3302 arguments. Update *EXPP as needed to hold more space. */
3305 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3306 int oplen
, struct symbol
*sym
,
3307 struct block
*block
)
3309 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3310 symbol, -oplen for operator being replaced). */
3311 struct expression
*newexp
= (struct expression
*)
3312 xmalloc (sizeof (struct expression
)
3313 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3314 struct expression
*exp
= *expp
;
3316 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3317 newexp
->language_defn
= exp
->language_defn
;
3318 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3319 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3320 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3322 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3323 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3325 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3326 newexp
->elts
[pc
+ 4].block
= block
;
3327 newexp
->elts
[pc
+ 5].symbol
= sym
;
3333 /* Type-class predicates */
3335 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3339 numeric_type_p (struct type
*type
)
3345 switch (TYPE_CODE (type
))
3350 case TYPE_CODE_RANGE
:
3351 return (type
== TYPE_TARGET_TYPE (type
)
3352 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3359 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3362 integer_type_p (struct type
*type
)
3368 switch (TYPE_CODE (type
))
3372 case TYPE_CODE_RANGE
:
3373 return (type
== TYPE_TARGET_TYPE (type
)
3374 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3381 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3384 scalar_type_p (struct type
*type
)
3390 switch (TYPE_CODE (type
))
3393 case TYPE_CODE_RANGE
:
3394 case TYPE_CODE_ENUM
:
3403 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3406 discrete_type_p (struct type
*type
)
3412 switch (TYPE_CODE (type
))
3415 case TYPE_CODE_RANGE
:
3416 case TYPE_CODE_ENUM
:
3424 /* Returns non-zero if OP with operands in the vector ARGS could be
3425 a user-defined function. Errs on the side of pre-defined operators
3426 (i.e., result 0). */
3429 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3431 struct type
*type0
=
3432 (args
[0] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[0]));
3433 struct type
*type1
=
3434 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
3448 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3452 case BINOP_BITWISE_AND
:
3453 case BINOP_BITWISE_IOR
:
3454 case BINOP_BITWISE_XOR
:
3455 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3458 case BINOP_NOTEQUAL
:
3463 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3467 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3468 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3469 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3470 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3471 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3472 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
))
3473 != TYPE_CODE_ARRAY
))));
3476 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3480 case UNOP_LOGICAL_NOT
:
3482 return (!numeric_type_p (type0
));
3489 /* NOTE: In the following, we assume that a renaming type's name may
3490 have an ___XD suffix. It would be nice if this went away at some
3493 /* If TYPE encodes a renaming, returns the renaming suffix, which
3494 is XR for an object renaming, XRP for a procedure renaming, XRE for
3495 an exception renaming, and XRS for a subprogram renaming. Returns
3496 NULL if NAME encodes none of these. */
3499 ada_renaming_type (struct type
*type
)
3501 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3503 const char *name
= type_name_no_tag (type
);
3504 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3506 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3515 /* Return non-zero iff SYM encodes an object renaming. */
3518 ada_is_object_renaming (struct symbol
*sym
)
3520 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3521 return renaming_type
!= NULL
3522 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3525 /* Assuming that SYM encodes a non-object renaming, returns the original
3526 name of the renamed entity. The name is good until the end of
3530 ada_simple_renamed_entity (struct symbol
*sym
)
3533 const char *raw_name
;
3537 type
= SYMBOL_TYPE (sym
);
3538 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3539 error ("Improperly encoded renaming.");
3541 raw_name
= TYPE_FIELD_NAME (type
, 0);
3542 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3544 error ("Improperly encoded renaming.");
3546 result
= xmalloc (len
+ 1);
3547 strncpy (result
, raw_name
, len
);
3548 result
[len
] = '\000';
3553 /* Evaluation: Function Calls */
3555 /* Return an lvalue containing the value VAL. This is the identity on
3556 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3557 on the stack, using and updating *SP as the stack pointer, and
3558 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3560 static struct value
*
3561 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3563 if (! VALUE_LVAL (val
))
3565 int len
= TYPE_LENGTH (check_typedef (VALUE_TYPE (val
)));
3567 /* The following is taken from the structure-return code in
3568 call_function_by_hand. FIXME: Therefore, some refactoring seems
3570 if (INNER_THAN (1, 2))
3572 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3573 reserving sufficient space. */
3575 if (gdbarch_frame_align_p (current_gdbarch
))
3576 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3577 VALUE_ADDRESS (val
) = *sp
;
3581 /* Stack grows upward. Align the frame, allocate space, and
3582 then again, re-align the frame. */
3583 if (gdbarch_frame_align_p (current_gdbarch
))
3584 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3585 VALUE_ADDRESS (val
) = *sp
;
3587 if (gdbarch_frame_align_p (current_gdbarch
))
3588 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3591 write_memory (VALUE_ADDRESS (val
), VALUE_CONTENTS_RAW (val
), len
);
3597 /* Return the value ACTUAL, converted to be an appropriate value for a
3598 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3599 allocating any necessary descriptors (fat pointers), or copies of
3600 values not residing in memory, updating it as needed. */
3602 static struct value
*
3603 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3606 struct type
*actual_type
= check_typedef (VALUE_TYPE (actual
));
3607 struct type
*formal_type
= check_typedef (formal_type0
);
3608 struct type
*formal_target
=
3609 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3610 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3611 struct type
*actual_target
=
3612 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3613 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3615 if (ada_is_array_descriptor_type (formal_target
)
3616 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3617 return make_array_descriptor (formal_type
, actual
, sp
);
3618 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3620 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3621 && ada_is_array_descriptor_type (actual_target
))
3622 return desc_data (actual
);
3623 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3625 if (VALUE_LVAL (actual
) != lval_memory
)
3628 actual_type
= check_typedef (VALUE_TYPE (actual
));
3629 val
= allocate_value (actual_type
);
3630 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3631 (char *) VALUE_CONTENTS (actual
),
3632 TYPE_LENGTH (actual_type
));
3633 actual
= ensure_lval (val
, sp
);
3635 return value_addr (actual
);
3638 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3639 return ada_value_ind (actual
);
3645 /* Push a descriptor of type TYPE for array value ARR on the stack at
3646 *SP, updating *SP to reflect the new descriptor. Return either
3647 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3648 to-descriptor type rather than a descriptor type), a struct value *
3649 representing a pointer to this descriptor. */
3651 static struct value
*
3652 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3654 struct type
*bounds_type
= desc_bounds_type (type
);
3655 struct type
*desc_type
= desc_base_type (type
);
3656 struct value
*descriptor
= allocate_value (desc_type
);
3657 struct value
*bounds
= allocate_value (bounds_type
);
3660 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3662 modify_general_field (VALUE_CONTENTS (bounds
),
3663 value_as_long (ada_array_bound (arr
, i
, 0)),
3664 desc_bound_bitpos (bounds_type
, i
, 0),
3665 desc_bound_bitsize (bounds_type
, i
, 0));
3666 modify_general_field (VALUE_CONTENTS (bounds
),
3667 value_as_long (ada_array_bound (arr
, i
, 1)),
3668 desc_bound_bitpos (bounds_type
, i
, 1),
3669 desc_bound_bitsize (bounds_type
, i
, 1));
3672 bounds
= ensure_lval (bounds
, sp
);
3674 modify_general_field (VALUE_CONTENTS (descriptor
),
3675 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3676 fat_pntr_data_bitpos (desc_type
),
3677 fat_pntr_data_bitsize (desc_type
));
3679 modify_general_field (VALUE_CONTENTS (descriptor
),
3680 VALUE_ADDRESS (bounds
),
3681 fat_pntr_bounds_bitpos (desc_type
),
3682 fat_pntr_bounds_bitsize (desc_type
));
3684 descriptor
= ensure_lval (descriptor
, sp
);
3686 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3687 return value_addr (descriptor
);
3693 /* Assuming a dummy frame has been established on the target, perform any
3694 conversions needed for calling function FUNC on the NARGS actual
3695 parameters in ARGS, other than standard C conversions. Does
3696 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3697 does not match the number of arguments expected. Use *SP as a
3698 stack pointer for additional data that must be pushed, updating its
3702 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3707 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3708 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3711 for (i
= 0; i
< nargs
; i
+= 1)
3713 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3716 /* Experimental Symbol Cache Module */
3718 /* This module may well have been OBE, due to improvements in the
3719 symbol-table module. So until proven otherwise, it is disabled in
3720 the submitted public code, and may be removed from all sources
3725 /* This section implements a simple, fixed-sized hash table for those
3726 Ada-mode symbols that get looked up in the course of executing the user's
3727 commands. The size is fixed on the grounds that there are not
3728 likely to be all that many symbols looked up during any given
3729 session, regardless of the size of the symbol table. If we decide
3730 to go to a resizable table, let's just use the stuff from libiberty
3733 #define HASH_SIZE 1009
3738 domain_enum
namespace;
3740 struct symtab
*symtab
;
3741 struct block
*block
;
3742 struct cache_entry
*next
;
3745 static struct obstack cache_space
;
3747 static struct cache_entry
*cache
[HASH_SIZE
];
3749 /* Clear all entries from the symbol cache. */
3752 clear_ada_sym_cache (void)
3754 obstack_free (&cache_space
, NULL
);
3755 obstack_init (&cache_space
);
3756 memset (cache
, '\000', sizeof (cache
));
3759 static struct cache_entry
**
3760 find_entry (const char *name
, domain_enum
namespace)
3762 int h
= msymbol_hash (name
) % HASH_SIZE
;
3763 struct cache_entry
**e
;
3764 for (e
= &cache
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
3766 if (namespace == (*e
)->namespace && strcmp (name
, (*e
)->name
) == 0)
3772 /* Return (in SYM) the last cached definition for global or static symbol NAME
3773 in namespace DOMAIN. Returns 1 if entry found, 0 otherwise.
3774 If SYMTAB is non-NULL, store the symbol
3775 table in which the symbol was found there, or NULL if not found.
3776 *BLOCK is set to the block in which NAME is found. */
3779 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3780 struct symbol
**sym
, struct block
**block
,
3781 struct symtab
**symtab
)
3783 struct cache_entry
**e
= find_entry (name
, namespace);
3789 *block
= (*e
)->block
;
3791 *symtab
= (*e
)->symtab
;
3795 /* Set the cached definition of NAME in DOMAIN to SYM in block
3796 BLOCK and symbol table SYMTAB. */
3799 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3800 struct block
*block
, struct symtab
*symtab
)
3802 int h
= msymbol_hash (name
) % HASH_SIZE
;
3804 struct cache_entry
*e
=
3805 (struct cache_entry
*) obstack_alloc (&cache_space
, sizeof (*e
));
3808 e
->name
= copy
= obstack_alloc (&cache_space
, strlen (name
) + 1);
3809 strcpy (copy
, name
);
3811 e
->namespace = namespace;
3818 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3819 struct symbol
**sym
, struct block
**block
,
3820 struct symtab
**symtab
)
3826 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3827 struct block
*block
, struct symtab
*symtab
)
3830 #endif /* GNAT_GDB */
3834 /* Return the result of a standard (literal, C-like) lookup of NAME in
3835 given DOMAIN, visible from lexical block BLOCK. */
3837 static struct symbol
*
3838 standard_lookup (const char *name
, const struct block
*block
,
3842 struct symtab
*symtab
;
3844 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3847 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3848 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3853 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3854 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3855 since they contend in overloading in the same way. */
3857 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3861 for (i
= 0; i
< n
; i
+= 1)
3862 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3863 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3864 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3870 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3871 struct types. Otherwise, they may not. */
3874 equiv_types (struct type
*type0
, struct type
*type1
)
3878 if (type0
== NULL
|| type1
== NULL
3879 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3881 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3882 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3883 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3884 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3890 /* True iff SYM0 represents the same entity as SYM1, or one that is
3891 no more defined than that of SYM1. */
3894 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3898 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3899 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3902 switch (SYMBOL_CLASS (sym0
))
3908 struct type
*type0
= SYMBOL_TYPE (sym0
);
3909 struct type
*type1
= SYMBOL_TYPE (sym1
);
3910 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3911 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3912 int len0
= strlen (name0
);
3914 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3915 && (equiv_types (type0
, type1
)
3916 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3917 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3920 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3921 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3927 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3928 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3931 add_defn_to_vec (struct obstack
*obstackp
,
3933 struct block
*block
, struct symtab
*symtab
)
3937 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3939 if (SYMBOL_TYPE (sym
) != NULL
)
3940 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3941 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3943 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3945 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3947 prevDefns
[i
].sym
= sym
;
3948 prevDefns
[i
].block
= block
;
3949 prevDefns
[i
].symtab
= symtab
;
3955 struct ada_symbol_info info
;
3959 info
.symtab
= symtab
;
3960 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3964 /* Number of ada_symbol_info structures currently collected in
3965 current vector in *OBSTACKP. */
3968 num_defns_collected (struct obstack
*obstackp
)
3970 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3973 /* Vector of ada_symbol_info structures currently collected in current
3974 vector in *OBSTACKP. If FINISH, close off the vector and return
3975 its final address. */
3977 static struct ada_symbol_info
*
3978 defns_collected (struct obstack
*obstackp
, int finish
)
3981 return obstack_finish (obstackp
);
3983 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3986 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3987 Check the global symbols if GLOBAL, the static symbols if not.
3988 Do wild-card match if WILD. */
3990 static struct partial_symbol
*
3991 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3992 int global
, domain_enum
namespace, int wild
)
3994 struct partial_symbol
**start
;
3995 int name_len
= strlen (name
);
3996 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
4005 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
4006 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
4010 for (i
= 0; i
< length
; i
+= 1)
4012 struct partial_symbol
*psym
= start
[i
];
4014 if (SYMBOL_DOMAIN (psym
) == namespace
4015 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
4029 int M
= (U
+ i
) >> 1;
4030 struct partial_symbol
*psym
= start
[M
];
4031 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
4033 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
4035 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
4046 struct partial_symbol
*psym
= start
[i
];
4048 if (SYMBOL_DOMAIN (psym
) == namespace)
4050 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
4058 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4072 int M
= (U
+ i
) >> 1;
4073 struct partial_symbol
*psym
= start
[M
];
4074 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
4076 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
4078 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4089 struct partial_symbol
*psym
= start
[i
];
4091 if (SYMBOL_DOMAIN (psym
) == namespace)
4095 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4098 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4100 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4110 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4120 /* Find a symbol table containing symbol SYM or NULL if none. */
4122 static struct symtab
*
4123 symtab_for_sym (struct symbol
*sym
)
4126 struct objfile
*objfile
;
4128 struct symbol
*tmp_sym
;
4129 struct dict_iterator iter
;
4132 ALL_SYMTABS (objfile
, s
)
4134 switch (SYMBOL_CLASS (sym
))
4142 case LOC_CONST_BYTES
:
4143 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4144 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4146 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4147 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4153 switch (SYMBOL_CLASS (sym
))
4159 case LOC_REGPARM_ADDR
:
4164 case LOC_BASEREG_ARG
:
4166 case LOC_COMPUTED_ARG
:
4167 for (j
= FIRST_LOCAL_BLOCK
;
4168 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4170 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4171 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
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. */
4187 struct minimal_symbol
*
4188 ada_lookup_simple_minsym (const char *name
)
4190 struct objfile
*objfile
;
4191 struct minimal_symbol
*msymbol
;
4194 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4196 name
+= sizeof ("standard__") - 1;
4200 wild_match
= (strstr (name
, "__") == NULL
);
4202 ALL_MSYMBOLS (objfile
, msymbol
)
4204 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4205 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4212 /* Return up minimal symbol for NAME, folded and encoded according to
4213 Ada conventions, or NULL if none. The last two arguments are ignored. */
4215 static struct minimal_symbol
*
4216 ada_lookup_minimal_symbol (const char *name
, const char *sfile
,
4217 struct objfile
*objf
)
4219 return ada_lookup_simple_minsym (ada_encode (name
));
4222 /* For all subprograms that statically enclose the subprogram of the
4223 selected frame, add symbols matching identifier NAME in DOMAIN
4224 and their blocks to the list of data in OBSTACKP, as for
4225 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4229 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4230 const char *name
, domain_enum
namespace,
4233 #ifdef HAVE_ADD_SYMBOLS_FROM_ENCLOSING_PROCS
4234 /* Use a heuristic to find the frames of enclosing subprograms: treat the
4235 pointer-sized value at location 0 from the local-variable base of a
4236 frame as a static link, and then search up the call stack for a
4237 frame with that same local-variable base. */
4238 static struct symbol static_link_sym
;
4239 static struct symbol
*static_link
;
4240 struct value
*target_link_val
;
4242 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4243 struct frame_info
*frame
;
4245 if (!target_has_stack
)
4248 if (static_link
== NULL
)
4250 /* Initialize the local variable symbol that stands for the
4251 static link (when there is one). */
4252 static_link
= &static_link_sym
;
4253 SYMBOL_LINKAGE_NAME (static_link
) = "";
4254 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
4255 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
4256 SYMBOL_DOMAIN (static_link
) = VAR_DOMAIN
;
4257 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
4258 SYMBOL_VALUE (static_link
) =
4259 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
4262 frame
= get_selected_frame ();
4263 if (frame
== NULL
|| inside_main_func (get_frame_address_in_block (frame
)))
4266 target_link_val
= read_var_value (static_link
, frame
);
4267 while (target_link_val
!= NULL
4268 && num_defns_collected (obstackp
) == 0
4269 && frame_relative_level (frame
) <= MAX_ENCLOSING_FRAME_LEVELS
)
4271 CORE_ADDR target_link
= value_as_address (target_link_val
);
4273 frame
= get_prev_frame (frame
);
4277 if (get_frame_locals_address (frame
) == target_link
)
4279 struct block
*block
;
4283 block
= get_frame_block (frame
, 0);
4284 while (block
!= NULL
&& block_function (block
) != NULL
4285 && num_defns_collected (obstackp
) == 0)
4289 ada_add_block_symbols (obstackp
, block
, name
, namespace,
4290 NULL
, NULL
, wild_match
);
4292 block
= BLOCK_SUPERBLOCK (block
);
4297 do_cleanups (old_chain
);
4301 /* FIXME: The next two routines belong in symtab.c */
4304 restore_language (void *lang
)
4306 set_language ((enum language
) lang
);
4309 /* As for lookup_symbol, but performed as if the current language
4313 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4314 domain_enum domain
, enum language lang
,
4315 int *is_a_field_of_this
, struct symtab
**symtab
)
4317 struct cleanup
*old_chain
4318 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4319 struct symbol
*result
;
4320 set_language (lang
);
4321 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4322 do_cleanups (old_chain
);
4326 /* True if TYPE is definitely an artificial type supplied to a symbol
4327 for which no debugging information was given in the symbol file. */
4330 is_nondebugging_type (struct type
*type
)
4332 char *name
= ada_type_name (type
);
4333 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4336 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4337 duplicate other symbols in the list (The only case I know of where
4338 this happens is when object files containing stabs-in-ecoff are
4339 linked with files containing ordinary ecoff debugging symbols (or no
4340 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4341 Returns the number of items in the modified list. */
4344 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4351 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4352 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4353 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4355 for (j
= 0; j
< nsyms
; j
+= 1)
4358 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4359 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4360 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4361 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4362 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4363 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4366 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4367 syms
[k
- 1] = syms
[k
];
4380 /* Given a type that corresponds to a renaming entity, use the type name
4381 to extract the scope (package name or function name, fully qualified,
4382 and following the GNAT encoding convention) where this renaming has been
4383 defined. The string returned needs to be deallocated after use. */
4386 xget_renaming_scope (struct type
*renaming_type
)
4388 /* The renaming types adhere to the following convention:
4389 <scope>__<rename>___<XR extension>.
4390 So, to extract the scope, we search for the "___XR" extension,
4391 and then backtrack until we find the first "__". */
4393 const char *name
= type_name_no_tag (renaming_type
);
4394 char *suffix
= strstr (name
, "___XR");
4399 /* Now, backtrack a bit until we find the first "__". Start looking
4400 at suffix - 3, as the <rename> part is at least one character long. */
4402 for (last
= suffix
- 3; last
> name
; last
--)
4403 if (last
[0] == '_' && last
[1] == '_')
4406 /* Make a copy of scope and return it. */
4408 scope_len
= last
- name
;
4409 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4411 strncpy (scope
, name
, scope_len
);
4412 scope
[scope_len
] = '\0';
4417 /* Return nonzero if NAME corresponds to a package name. */
4420 is_package_name (const char *name
)
4422 /* Here, We take advantage of the fact that no symbols are generated
4423 for packages, while symbols are generated for each function.
4424 So the condition for NAME represent a package becomes equivalent
4425 to NAME not existing in our list of symbols. There is only one
4426 small complication with library-level functions (see below). */
4430 /* If it is a function that has not been defined at library level,
4431 then we should be able to look it up in the symbols. */
4432 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4435 /* Library-level function names start with "_ada_". See if function
4436 "_ada_" followed by NAME can be found. */
4438 /* Do a quick check that NAME does not contain "__", since library-level
4439 functions names can not contain "__" in them. */
4440 if (strstr (name
, "__") != NULL
)
4443 fun_name
= xstrprintf ("_ada_%s", name
);
4445 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4448 /* Return nonzero if SYM corresponds to a renaming entity that is
4449 visible from FUNCTION_NAME. */
4452 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4454 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4456 make_cleanup (xfree
, scope
);
4458 /* If the rename has been defined in a package, then it is visible. */
4459 if (is_package_name (scope
))
4462 /* Check that the rename is in the current function scope by checking
4463 that its name starts with SCOPE. */
4465 /* If the function name starts with "_ada_", it means that it is
4466 a library-level function. Strip this prefix before doing the
4467 comparison, as the encoding for the renaming does not contain
4469 if (strncmp (function_name
, "_ada_", 5) == 0)
4472 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4475 /* Iterates over the SYMS list and remove any entry that corresponds to
4476 a renaming entity that is not visible from the function associated
4480 GNAT emits a type following a specified encoding for each renaming
4481 entity. Unfortunately, STABS currently does not support the definition
4482 of types that are local to a given lexical block, so all renamings types
4483 are emitted at library level. As a consequence, if an application
4484 contains two renaming entities using the same name, and a user tries to
4485 print the value of one of these entities, the result of the ada symbol
4486 lookup will also contain the wrong renaming type.
4488 This function partially covers for this limitation by attempting to
4489 remove from the SYMS list renaming symbols that should be visible
4490 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4491 method with the current information available. The implementation
4492 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4494 - When the user tries to print a rename in a function while there
4495 is another rename entity defined in a package: Normally, the
4496 rename in the function has precedence over the rename in the
4497 package, so the latter should be removed from the list. This is
4498 currently not the case.
4500 - This function will incorrectly remove valid renames if
4501 the CURRENT_BLOCK corresponds to a function which symbol name
4502 has been changed by an "Export" pragma. As a consequence,
4503 the user will be unable to print such rename entities. */
4506 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4507 int nsyms
, struct block
*current_block
)
4509 struct symbol
*current_function
;
4510 char *current_function_name
;
4513 /* Extract the function name associated to CURRENT_BLOCK.
4514 Abort if unable to do so. */
4516 if (current_block
== NULL
)
4519 current_function
= block_function (current_block
);
4520 if (current_function
== NULL
)
4523 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4524 if (current_function_name
== NULL
)
4527 /* Check each of the symbols, and remove it from the list if it is
4528 a type corresponding to a renaming that is out of the scope of
4529 the current block. */
4534 if (ada_is_object_renaming (syms
[i
].sym
)
4535 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4538 for (j
= i
+ 1; j
< nsyms
; j
++)
4539 syms
[j
- 1] = syms
[j
];
4549 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4550 scope and in global scopes, returning the number of matches. Sets
4551 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4552 indicating the symbols found and the blocks and symbol tables (if
4553 any) in which they were found. This vector are transient---good only to
4554 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4555 symbol match within the nest of blocks whose innermost member is BLOCK0,
4556 is the one match returned (no other matches in that or
4557 enclosing blocks is returned). If there are any matches in or
4558 surrounding BLOCK0, then these alone are returned. Otherwise, the
4559 search extends to global and file-scope (static) symbol tables.
4560 Names prefixed with "standard__" are handled specially: "standard__"
4561 is first stripped off, and only static and global symbols are searched. */
4564 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4565 domain_enum
namespace,
4566 struct ada_symbol_info
**results
)
4570 struct partial_symtab
*ps
;
4571 struct blockvector
*bv
;
4572 struct objfile
*objfile
;
4573 struct block
*block
;
4575 struct minimal_symbol
*msymbol
;
4581 obstack_free (&symbol_list_obstack
, NULL
);
4582 obstack_init (&symbol_list_obstack
);
4586 /* Search specified block and its superiors. */
4588 wild_match
= (strstr (name0
, "__") == NULL
);
4590 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4591 needed, but adding const will
4592 have a cascade effect. */
4593 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4597 name
= name0
+ sizeof ("standard__") - 1;
4601 while (block
!= NULL
)
4604 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4605 namespace, NULL
, NULL
, wild_match
);
4607 /* If we found a non-function match, assume that's the one. */
4608 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4609 num_defns_collected (&symbol_list_obstack
)))
4612 block
= BLOCK_SUPERBLOCK (block
);
4615 /* If no luck so far, try to find NAME as a local symbol in some lexically
4616 enclosing subprogram. */
4617 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4618 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4619 name
, namespace, wild_match
);
4621 /* If we found ANY matches among non-global symbols, we're done. */
4623 if (num_defns_collected (&symbol_list_obstack
) > 0)
4627 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4630 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4634 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4635 tables, and psymtab's. */
4637 ALL_SYMTABS (objfile
, s
)
4642 bv
= BLOCKVECTOR (s
);
4643 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4644 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4645 objfile
, s
, wild_match
);
4648 if (namespace == VAR_DOMAIN
)
4650 ALL_MSYMBOLS (objfile
, msymbol
)
4652 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4654 switch (MSYMBOL_TYPE (msymbol
))
4656 case mst_solib_trampoline
:
4659 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4662 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4664 bv
= BLOCKVECTOR (s
);
4665 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4666 ada_add_block_symbols (&symbol_list_obstack
, block
,
4667 SYMBOL_LINKAGE_NAME (msymbol
),
4668 namespace, objfile
, s
, wild_match
);
4670 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4672 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4673 ada_add_block_symbols (&symbol_list_obstack
, block
,
4674 SYMBOL_LINKAGE_NAME (msymbol
),
4675 namespace, objfile
, s
,
4684 ALL_PSYMTABS (objfile
, ps
)
4688 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4690 s
= PSYMTAB_TO_SYMTAB (ps
);
4693 bv
= BLOCKVECTOR (s
);
4694 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4695 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4696 namespace, objfile
, s
, wild_match
);
4700 /* Now add symbols from all per-file blocks if we've gotten no hits
4701 (Not strictly correct, but perhaps better than an error).
4702 Do the symtabs first, then check the psymtabs. */
4704 if (num_defns_collected (&symbol_list_obstack
) == 0)
4707 ALL_SYMTABS (objfile
, s
)
4712 bv
= BLOCKVECTOR (s
);
4713 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4714 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4715 objfile
, s
, wild_match
);
4718 ALL_PSYMTABS (objfile
, ps
)
4722 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4724 s
= PSYMTAB_TO_SYMTAB (ps
);
4725 bv
= BLOCKVECTOR (s
);
4728 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4729 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4730 namespace, objfile
, s
, wild_match
);
4736 ndefns
= num_defns_collected (&symbol_list_obstack
);
4737 *results
= defns_collected (&symbol_list_obstack
, 1);
4739 ndefns
= remove_extra_symbols (*results
, ndefns
);
4742 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4744 if (ndefns
== 1 && cacheIfUnique
)
4745 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4746 (*results
)[0].symtab
);
4748 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4749 (struct block
*) block0
);
4754 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4755 scope and in global scopes, or NULL if none. NAME is folded and
4756 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4757 but is disambiguated by user query if needed. *IS_A_FIELD_OF_THIS is
4758 set to 0 and *SYMTAB is set to the symbol table in which the symbol
4759 was found (in both cases, these assignments occur only if the
4760 pointers are non-null). */
4764 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4765 domain_enum
namespace, int *is_a_field_of_this
,
4766 struct symtab
**symtab
)
4768 struct ada_symbol_info
*candidates
;
4771 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4772 block0
, namespace, &candidates
);
4774 if (n_candidates
== 0)
4776 else if (n_candidates
!= 1)
4777 user_select_syms (candidates
, n_candidates
, 1);
4779 if (is_a_field_of_this
!= NULL
)
4780 *is_a_field_of_this
= 0;
4784 *symtab
= candidates
[0].symtab
;
4785 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4787 struct objfile
*objfile
;
4790 struct blockvector
*bv
;
4792 /* Search the list of symtabs for one which contains the
4793 address of the start of this block. */
4794 ALL_SYMTABS (objfile
, s
)
4796 bv
= BLOCKVECTOR (s
);
4797 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4798 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4799 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4802 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4804 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4808 return candidates
[0].sym
;
4811 static struct symbol
*
4812 ada_lookup_symbol_nonlocal (const char *name
,
4813 const char *linkage_name
,
4814 const struct block
*block
,
4815 const domain_enum domain
, struct symtab
**symtab
)
4817 if (linkage_name
== NULL
)
4818 linkage_name
= name
;
4819 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4824 /* True iff STR is a possible encoded suffix of a normal Ada name
4825 that is to be ignored for matching purposes. Suffixes of parallel
4826 names (e.g., XVE) are not included here. Currently, the possible suffixes
4827 are given by either of the regular expression:
4829 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4831 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4832 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(LJM|X([FDBUP].*|R[^T]?)))?$
4836 is_name_suffix (const char *str
)
4839 const char *matching
;
4840 const int len
= strlen (str
);
4842 /* (__[0-9]+)?\.[0-9]+ */
4844 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4847 while (isdigit (matching
[0]))
4849 if (matching
[0] == '\0')
4853 if (matching
[0] == '.')
4856 while (isdigit (matching
[0]))
4858 if (matching
[0] == '\0')
4863 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4866 while (isdigit (matching
[0]))
4868 if (matching
[0] == '\0')
4872 /* ??? We should not modify STR directly, as we are doing below. This
4873 is fine in this case, but may become problematic later if we find
4874 that this alternative did not work, and want to try matching
4875 another one from the begining of STR. Since we modified it, we
4876 won't be able to find the begining of the string anymore! */
4880 while (str
[0] != '_' && str
[0] != '\0')
4882 if (str
[0] != 'n' && str
[0] != 'b')
4887 if (str
[0] == '\000')
4891 if (str
[1] != '_' || str
[2] == '\000')
4895 if (strcmp (str
+ 3, "LJM") == 0)
4899 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4900 || str
[4] == 'U' || str
[4] == 'P')
4902 if (str
[4] == 'R' && str
[5] != 'T')
4906 if (!isdigit (str
[2]))
4908 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4909 if (!isdigit (str
[k
]) && str
[k
] != '_')
4913 if (str
[0] == '$' && isdigit (str
[1]))
4915 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4916 if (!isdigit (str
[k
]) && str
[k
] != '_')
4923 /* Return nonzero if the given string starts with a dot ('.')
4924 followed by zero or more digits.
4926 Note: brobecker/2003-11-10: A forward declaration has not been
4927 added at the begining of this file yet, because this function
4928 is only used to work around a problem found during wild matching
4929 when trying to match minimal symbol names against symbol names
4930 obtained from dwarf-2 data. This function is therefore currently
4931 only used in wild_match() and is likely to be deleted when the
4932 problem in dwarf-2 is fixed. */
4935 is_dot_digits_suffix (const char *str
)
4941 while (isdigit (str
[0]))
4943 return (str
[0] == '\0');
4946 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4947 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4948 informational suffixes of NAME (i.e., for which is_name_suffix is
4952 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4958 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4959 stored in the symbol table for nested function names is sometimes
4960 different from the name of the associated entity stored in
4961 the dwarf-2 data: This is the case for nested subprograms, where
4962 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4963 while the symbol name from the dwarf-2 data does not.
4965 Although the DWARF-2 standard documents that entity names stored
4966 in the dwarf-2 data should be identical to the name as seen in
4967 the source code, GNAT takes a different approach as we already use
4968 a special encoding mechanism to convey the information so that
4969 a C debugger can still use the information generated to debug
4970 Ada programs. A corollary is that the symbol names in the dwarf-2
4971 data should match the names found in the symbol table. I therefore
4972 consider this issue as a compiler defect.
4974 Until the compiler is properly fixed, we work-around the problem
4975 by ignoring such suffixes during the match. We do so by making
4976 a copy of PATN0 and NAME0, and then by stripping such a suffix
4977 if present. We then perform the match on the resulting strings. */
4980 name_len
= strlen (name0
);
4982 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4983 strcpy (name
, name0
);
4984 dot
= strrchr (name
, '.');
4985 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4988 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4989 strncpy (patn
, patn0
, patn_len
);
4990 patn
[patn_len
] = '\0';
4991 dot
= strrchr (patn
, '.');
4992 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4995 patn_len
= dot
- patn
;
4999 /* Now perform the wild match. */
5001 name_len
= strlen (name
);
5002 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
5003 && strncmp (patn
, name
+ 5, patn_len
) == 0
5004 && is_name_suffix (name
+ patn_len
+ 5))
5007 while (name_len
>= patn_len
)
5009 if (strncmp (patn
, name
, patn_len
) == 0
5010 && is_name_suffix (name
+ patn_len
))
5018 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
5023 if (!islower (name
[2]))
5030 if (!islower (name
[1]))
5041 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5042 vector *defn_symbols, updating the list of symbols in OBSTACKP
5043 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5044 OBJFILE is the section containing BLOCK.
5045 SYMTAB is recorded with each symbol added. */
5048 ada_add_block_symbols (struct obstack
*obstackp
,
5049 struct block
*block
, const char *name
,
5050 domain_enum domain
, struct objfile
*objfile
,
5051 struct symtab
*symtab
, int wild
)
5053 struct dict_iterator iter
;
5054 int name_len
= strlen (name
);
5055 /* A matching argument symbol, if any. */
5056 struct symbol
*arg_sym
;
5057 /* Set true when we find a matching non-argument symbol. */
5066 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5068 if (SYMBOL_DOMAIN (sym
) == domain
5069 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5071 switch (SYMBOL_CLASS (sym
))
5077 case LOC_REGPARM_ADDR
:
5078 case LOC_BASEREG_ARG
:
5079 case LOC_COMPUTED_ARG
:
5082 case LOC_UNRESOLVED
:
5086 add_defn_to_vec (obstackp
,
5087 fixup_symbol_section (sym
, objfile
),
5096 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5098 if (SYMBOL_DOMAIN (sym
) == domain
)
5100 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5102 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5104 switch (SYMBOL_CLASS (sym
))
5110 case LOC_REGPARM_ADDR
:
5111 case LOC_BASEREG_ARG
:
5112 case LOC_COMPUTED_ARG
:
5115 case LOC_UNRESOLVED
:
5119 add_defn_to_vec (obstackp
,
5120 fixup_symbol_section (sym
, objfile
),
5129 if (!found_sym
&& arg_sym
!= NULL
)
5131 add_defn_to_vec (obstackp
,
5132 fixup_symbol_section (arg_sym
, objfile
),
5141 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5143 if (SYMBOL_DOMAIN (sym
) == domain
)
5147 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5150 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5152 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5157 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5159 switch (SYMBOL_CLASS (sym
))
5165 case LOC_REGPARM_ADDR
:
5166 case LOC_BASEREG_ARG
:
5167 case LOC_COMPUTED_ARG
:
5170 case LOC_UNRESOLVED
:
5174 add_defn_to_vec (obstackp
,
5175 fixup_symbol_section (sym
, objfile
),
5184 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5185 They aren't parameters, right? */
5186 if (!found_sym
&& arg_sym
!= NULL
)
5188 add_defn_to_vec (obstackp
,
5189 fixup_symbol_section (arg_sym
, objfile
),
5197 /* Symbol Completion */
5199 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5200 name in a form that's appropriate for the completion. The result
5201 does not need to be deallocated, but is only good until the next call.
5203 TEXT_LEN is equal to the length of TEXT.
5204 Perform a wild match if WILD_MATCH is set.
5205 ENCODED should be set if TEXT represents the start of a symbol name
5206 in its encoded form. */
5209 symbol_completion_match (const char *sym_name
,
5210 const char *text
, int text_len
,
5211 int wild_match
, int encoded
)
5214 const int verbatim_match
= (text
[0] == '<');
5219 /* Strip the leading angle bracket. */
5224 /* First, test against the fully qualified name of the symbol. */
5226 if (strncmp (sym_name
, text
, text_len
) == 0)
5229 if (match
&& !encoded
)
5231 /* One needed check before declaring a positive match is to verify
5232 that iff we are doing a verbatim match, the decoded version
5233 of the symbol name starts with '<'. Otherwise, this symbol name
5234 is not a suitable completion. */
5235 const char *sym_name_copy
= sym_name
;
5236 int has_angle_bracket
;
5238 sym_name
= ada_decode (sym_name
);
5239 has_angle_bracket
= (sym_name
[0] == '<');
5240 match
= (has_angle_bracket
== verbatim_match
);
5241 sym_name
= sym_name_copy
;
5244 if (match
&& !verbatim_match
)
5246 /* When doing non-verbatim match, another check that needs to
5247 be done is to verify that the potentially matching symbol name
5248 does not include capital letters, because the ada-mode would
5249 not be able to understand these symbol names without the
5250 angle bracket notation. */
5253 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5258 /* Second: Try wild matching... */
5260 if (!match
&& wild_match
)
5262 /* Since we are doing wild matching, this means that TEXT
5263 may represent an unqualified symbol name. We therefore must
5264 also compare TEXT against the unqualified name of the symbol. */
5265 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5267 if (strncmp (sym_name
, text
, text_len
) == 0)
5271 /* Finally: If we found a mach, prepare the result to return. */
5277 sym_name
= add_angle_brackets (sym_name
);
5280 sym_name
= ada_decode (sym_name
);
5285 /* A companion function to ada_make_symbol_completion_list().
5286 Check if SYM_NAME represents a symbol which name would be suitable
5287 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5288 it is appended at the end of the given string vector SV.
5290 ORIG_TEXT is the string original string from the user command
5291 that needs to be completed. WORD is the entire command on which
5292 completion should be performed. These two parameters are used to
5293 determine which part of the symbol name should be added to the
5295 if WILD_MATCH is set, then wild matching is performed.
5296 ENCODED should be set if TEXT represents a symbol name in its
5297 encoded formed (in which case the completion should also be
5301 symbol_completion_add (struct string_vector
*sv
,
5302 const char *sym_name
,
5303 const char *text
, int text_len
,
5304 const char *orig_text
, const char *word
,
5305 int wild_match
, int encoded
)
5307 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5308 wild_match
, encoded
);
5314 /* We found a match, so add the appropriate completion to the given
5317 if (word
== orig_text
)
5319 completion
= xmalloc (strlen (match
) + 5);
5320 strcpy (completion
, match
);
5322 else if (word
> orig_text
)
5324 /* Return some portion of sym_name. */
5325 completion
= xmalloc (strlen (match
) + 5);
5326 strcpy (completion
, match
+ (word
- orig_text
));
5330 /* Return some of ORIG_TEXT plus sym_name. */
5331 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5332 strncpy (completion
, word
, orig_text
- word
);
5333 completion
[orig_text
- word
] = '\0';
5334 strcat (completion
, match
);
5337 string_vector_append (sv
, completion
);
5340 /* Return a list of possible symbol names completing TEXT0. The list
5341 is NULL terminated. WORD is the entire command on which completion
5345 ada_make_symbol_completion_list (const char *text0
, const char *word
)
5347 /* Note: This function is almost a copy of make_symbol_completion_list(),
5348 except it has been adapted for Ada. It is somewhat of a shame to
5349 duplicate so much code, but we don't really have the infrastructure
5350 yet to develop a language-aware version of he symbol completer... */
5355 struct string_vector result
= xnew_string_vector (128);
5358 struct partial_symtab
*ps
;
5359 struct minimal_symbol
*msymbol
;
5360 struct objfile
*objfile
;
5361 struct block
*b
, *surrounding_static_block
= 0;
5363 struct dict_iterator iter
;
5365 if (text0
[0] == '<')
5367 text
= xstrdup (text0
);
5368 make_cleanup (xfree
, text
);
5369 text_len
= strlen (text
);
5375 text
= xstrdup (ada_encode (text0
));
5376 make_cleanup (xfree
, text
);
5377 text_len
= strlen (text
);
5378 for (i
= 0; i
< text_len
; i
++)
5379 text
[i
] = tolower (text
[i
]);
5381 /* FIXME: brobecker/2003-09-17: When we get rid of ADA_RETAIN_DOTS,
5382 we can restrict the wild_match check to searching "__" only. */
5383 wild_match
= (strstr (text0
, "__") == NULL
5384 && strchr (text0
, '.') == NULL
);
5385 encoded
= (strstr (text0
, "__") != NULL
);
5388 /* First, look at the partial symtab symbols. */
5389 ALL_PSYMTABS (objfile
, ps
)
5391 struct partial_symbol
**psym
;
5393 /* If the psymtab's been read in we'll get it when we search
5394 through the blockvector. */
5398 for (psym
= objfile
->global_psymbols
.list
+ ps
->globals_offset
;
5399 psym
< (objfile
->global_psymbols
.list
+ ps
->globals_offset
5400 + ps
->n_global_syms
); psym
++)
5403 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (*psym
),
5404 text
, text_len
, text0
, word
,
5405 wild_match
, encoded
);
5408 for (psym
= objfile
->static_psymbols
.list
+ ps
->statics_offset
;
5409 psym
< (objfile
->static_psymbols
.list
+ ps
->statics_offset
5410 + ps
->n_static_syms
); psym
++)
5413 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (*psym
),
5414 text
, text_len
, text0
, word
,
5415 wild_match
, encoded
);
5419 /* At this point scan through the misc symbol vectors and add each
5420 symbol you find to the list. Eventually we want to ignore
5421 anything that isn't a text symbol (everything else will be
5422 handled by the psymtab code above). */
5424 ALL_MSYMBOLS (objfile
, msymbol
)
5427 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (msymbol
),
5428 text
, text_len
, text0
, word
, wild_match
, encoded
);
5431 /* Search upwards from currently selected frame (so that we can
5432 complete on local vars. */
5434 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5436 if (!BLOCK_SUPERBLOCK (b
))
5437 surrounding_static_block
= b
; /* For elmin of dups */
5439 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5441 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5442 text
, text_len
, text0
, word
,
5443 wild_match
, encoded
);
5447 /* Go through the symtabs and check the externs and statics for
5448 symbols which match. */
5450 ALL_SYMTABS (objfile
, s
)
5453 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5454 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5456 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5457 text
, text_len
, text0
, word
,
5458 wild_match
, encoded
);
5462 ALL_SYMTABS (objfile
, s
)
5465 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5466 /* Don't do this block twice. */
5467 if (b
== surrounding_static_block
)
5469 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5471 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5472 text
, text_len
, text0
, word
,
5473 wild_match
, encoded
);
5477 /* Append the closing NULL entry. */
5478 string_vector_append (&result
, NULL
);
5480 return (result
.array
);
5483 #endif /* GNAT_GDB */
5486 /* Breakpoint-related */
5488 /* Assuming that LINE is pointing at the beginning of an argument to
5489 'break', return a pointer to the delimiter for the initial segment
5490 of that name. This is the first ':', ' ', or end of LINE. */
5493 ada_start_decode_line_1 (char *line
)
5495 /* NOTE: strpbrk would be more elegant, but I am reluctant to be
5496 the first to use such a library function in GDB code. */
5498 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
5503 /* *SPEC points to a function and line number spec (as in a break
5504 command), following any initial file name specification.
5506 Return all symbol table/line specfications (sals) consistent with the
5507 information in *SPEC and FILE_TABLE in the following sense:
5508 + FILE_TABLE is null, or the sal refers to a line in the file
5509 named by FILE_TABLE.
5510 + If *SPEC points to an argument with a trailing ':LINENUM',
5511 then the sal refers to that line (or one following it as closely as
5513 + If *SPEC does not start with '*', the sal is in a function with
5516 Returns with 0 elements if no matching non-minimal symbols found.
5518 If *SPEC begins with a function name of the form <NAME>, then NAME
5519 is taken as a literal name; otherwise the function name is subject
5520 to the usual encoding.
5522 *SPEC is updated to point after the function/line number specification.
5524 FUNFIRSTLINE is non-zero if we desire the first line of real code
5527 If CANONICAL is non-NULL, and if any of the sals require a
5528 'canonical line spec', then *CANONICAL is set to point to an array
5529 of strings, corresponding to and equal in length to the returned
5530 list of sals, such that (*CANONICAL)[i] is non-null and contains a
5531 canonical line spec for the ith returned sal, if needed. If no
5532 canonical line specs are required and CANONICAL is non-null,
5533 *CANONICAL is set to NULL.
5535 A 'canonical line spec' is simply a name (in the format of the
5536 breakpoint command) that uniquely identifies a breakpoint position,
5537 with no further contextual information or user selection. It is
5538 needed whenever the file name, function name, and line number
5539 information supplied is insufficient for this unique
5540 identification. Currently overloaded functions, the name '*',
5541 or static functions without a filename yield a canonical line spec.
5542 The array and the line spec strings are allocated on the heap; it
5543 is the caller's responsibility to free them. */
5545 struct symtabs_and_lines
5546 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
5547 int funfirstline
, char ***canonical
)
5549 struct ada_symbol_info
*symbols
;
5550 const struct block
*block
;
5551 int n_matches
, i
, line_num
;
5552 struct symtabs_and_lines selected
;
5553 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
5559 char *unquoted_name
;
5561 if (file_table
== NULL
)
5562 block
= block_static_block (get_selected_block (0));
5564 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
5566 if (canonical
!= NULL
)
5567 *canonical
= (char **) NULL
;
5569 is_quoted
= (**spec
&& strchr (get_gdb_completer_quote_characters (),
5578 *spec
= skip_quoted (*spec
);
5579 while (**spec
!= '\000'
5580 && !strchr (ada_completer_word_break_characters
, **spec
))
5586 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
5588 line_num
= strtol (*spec
+ 1, spec
, 10);
5589 while (**spec
== ' ' || **spec
== '\t')
5596 error ("Wild-card function with no line number or file name.");
5598 return ada_sals_for_line (file_table
->filename
, line_num
,
5599 funfirstline
, canonical
, 0);
5602 if (name
[0] == '\'')
5610 unquoted_name
= (char *) alloca (len
- 1);
5611 memcpy (unquoted_name
, name
+ 1, len
- 2);
5612 unquoted_name
[len
- 2] = '\000';
5617 unquoted_name
= (char *) alloca (len
+ 1);
5618 memcpy (unquoted_name
, name
, len
);
5619 unquoted_name
[len
] = '\000';
5620 lower_name
= (char *) alloca (len
+ 1);
5621 for (i
= 0; i
< len
; i
+= 1)
5622 lower_name
[i
] = tolower (name
[i
]);
5623 lower_name
[len
] = '\000';
5627 if (lower_name
!= NULL
)
5628 n_matches
= ada_lookup_symbol_list (ada_encode (lower_name
), block
,
5629 VAR_DOMAIN
, &symbols
);
5631 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
5632 VAR_DOMAIN
, &symbols
);
5633 if (n_matches
== 0 && line_num
>= 0)
5634 error ("No line number information found for %s.", unquoted_name
);
5635 else if (n_matches
== 0)
5637 #ifdef HPPA_COMPILER_BUG
5638 /* FIXME: See comment in symtab.c::decode_line_1 */
5640 volatile struct symtab_and_line val
;
5641 #define volatile /*nothing */
5643 struct symtab_and_line val
;
5645 struct minimal_symbol
*msymbol
;
5650 if (lower_name
!= NULL
)
5651 msymbol
= ada_lookup_simple_minsym (ada_encode (lower_name
));
5652 if (msymbol
== NULL
)
5653 msymbol
= ada_lookup_simple_minsym (unquoted_name
);
5654 if (msymbol
!= NULL
)
5656 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
5657 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
5660 val
.pc
= gdbarch_convert_from_func_ptr_addr (current_gdbarch
,
5663 SKIP_PROLOGUE (val
.pc
);
5665 selected
.sals
= (struct symtab_and_line
*)
5666 xmalloc (sizeof (struct symtab_and_line
));
5667 selected
.sals
[0] = val
;
5672 if (!have_full_symbols ()
5673 && !have_partial_symbols () && !have_minimal_symbols ())
5674 error ("No symbol table is loaded. Use the \"file\" command.");
5676 error ("Function \"%s\" not defined.", unquoted_name
);
5677 return selected
; /* for lint */
5682 struct symtabs_and_lines best_sal
=
5683 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
5684 symbols
, n_matches
);
5686 adjust_pc_past_prologue (&best_sal
.sals
[0].pc
);
5691 selected
.nelts
= user_select_syms (symbols
, n_matches
, n_matches
);
5694 selected
.sals
= (struct symtab_and_line
*)
5695 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
5696 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
5697 make_cleanup (xfree
, selected
.sals
);
5700 while (i
< selected
.nelts
)
5702 if (SYMBOL_CLASS (symbols
[i
].sym
) == LOC_BLOCK
)
5704 = find_function_start_sal (symbols
[i
].sym
, funfirstline
);
5705 else if (SYMBOL_LINE (symbols
[i
].sym
) != 0)
5707 selected
.sals
[i
].symtab
=
5709 ? symbols
[i
].symtab
: symtab_for_sym (symbols
[i
].sym
);
5710 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
].sym
);
5712 else if (line_num
>= 0)
5714 /* Ignore this choice */
5715 symbols
[i
] = symbols
[selected
.nelts
- 1];
5716 selected
.nelts
-= 1;
5720 error ("Line number not known for symbol \"%s\"", unquoted_name
);
5724 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
5726 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
5727 for (i
= 0; i
< selected
.nelts
; i
+= 1)
5729 extended_canonical_line_spec (selected
.sals
[i
],
5730 SYMBOL_PRINT_NAME (symbols
[i
].sym
));
5733 discard_cleanups (old_chain
);
5737 /* The (single) sal corresponding to line LINE_NUM in a symbol table
5738 with file name FILENAME that occurs in one of the functions listed
5739 in the symbol fields of SYMBOLS[0 .. NSYMS-1]. */
5741 static struct symtabs_and_lines
5742 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
5743 struct ada_symbol_info
*symbols
, int nsyms
)
5745 struct symtabs_and_lines sals
;
5746 int best_index
, best
;
5747 struct linetable
*best_linetable
;
5748 struct objfile
*objfile
;
5750 struct symtab
*best_symtab
;
5752 read_all_symtabs (filename
);
5755 best_linetable
= NULL
;
5758 ALL_SYMTABS (objfile
, s
)
5760 struct linetable
*l
;
5765 if (strcmp (filename
, s
->filename
) != 0)
5768 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
5778 if (best
== 0 || l
->item
[ind
].line
< best
)
5780 best
= l
->item
[ind
].line
;
5789 error ("Line number not found in designated function.");
5794 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
5796 init_sal (&sals
.sals
[0]);
5798 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
5799 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
5800 sals
.sals
[0].symtab
= best_symtab
;
5805 /* Return the index in LINETABLE of the best match for LINE_NUM whose
5806 pc falls within one of the functions denoted by the symbol fields
5807 of SYMBOLS[0..NSYMS-1]. Set *EXACTP to 1 if the match is exact,
5811 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
5812 struct ada_symbol_info
*symbols
, int nsyms
,
5815 int i
, len
, best_index
, best
;
5817 if (line_num
<= 0 || linetable
== NULL
)
5820 len
= linetable
->nitems
;
5821 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
5824 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5826 for (k
= 0; k
< nsyms
; k
+= 1)
5828 if (symbols
[k
].sym
!= NULL
5829 && SYMBOL_CLASS (symbols
[k
].sym
) == LOC_BLOCK
5830 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
].sym
))
5831 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
].sym
)))
5838 if (item
->line
== line_num
)
5844 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
5855 /* Find the smallest k >= LINE_NUM such that k is a line number in
5856 LINETABLE, and k falls strictly within a named function that begins at
5857 or before LINE_NUM. Return -1 if there is no such k. */
5860 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
5864 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
5866 len
= linetable
->nitems
;
5872 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5874 if (item
->line
>= line_num
&& item
->line
< best
)
5877 CORE_ADDR start
, end
;
5880 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
5882 if (func_name
!= NULL
&& item
->pc
< end
)
5884 if (item
->line
== line_num
)
5888 struct symbol
*sym
=
5889 standard_lookup (func_name
, NULL
, VAR_DOMAIN
);
5890 if (is_plausible_func_for_line (sym
, line_num
))
5896 while (i
< len
&& linetable
->item
[i
].pc
< end
);
5906 return (best
== INT_MAX
) ? -1 : best
;
5910 /* Return the next higher index, k, into LINETABLE such that k > IND,
5911 entry k in LINETABLE has a line number equal to LINE_NUM, k
5912 corresponds to a PC that is in a function different from that
5913 corresponding to IND, and falls strictly within a named function
5914 that begins at a line at or preceding STARTING_LINE.
5915 Return -1 if there is no such k.
5916 IND == -1 corresponds to no function. */
5919 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
5920 int starting_line
, int ind
)
5924 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
5926 len
= linetable
->nitems
;
5930 CORE_ADDR start
, end
;
5932 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
5933 (char **) NULL
, &start
, &end
))
5935 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
5947 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5949 if (item
->line
>= line_num
)
5952 CORE_ADDR start
, end
;
5955 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
5957 if (func_name
!= NULL
&& item
->pc
< end
)
5959 if (item
->line
== line_num
)
5961 struct symbol
*sym
=
5962 standard_lookup (func_name
, NULL
, VAR_DOMAIN
);
5963 if (is_plausible_func_for_line (sym
, starting_line
))
5967 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
5979 /* True iff function symbol SYM starts somewhere at or before line #
5983 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
5985 struct symtab_and_line start_sal
;
5990 start_sal
= find_function_start_sal (sym
, 0);
5992 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
5995 /* Read in all symbol tables corresponding to partial symbol tables
5996 with file name FILENAME. */
5999 read_all_symtabs (const char *filename
)
6001 struct partial_symtab
*ps
;
6002 struct objfile
*objfile
;
6004 ALL_PSYMTABS (objfile
, ps
)
6008 if (strcmp (filename
, ps
->filename
) == 0)
6009 PSYMTAB_TO_SYMTAB (ps
);
6013 /* All sals corresponding to line LINE_NUM in a symbol table from file
6014 FILENAME, as filtered by the user. Filter out any lines that
6015 reside in functions with "suppressed" names (not corresponding to
6016 explicit Ada functions), if there is at least one in a function
6017 with a non-suppressed name. If CANONICAL is not null, set
6018 it to a corresponding array of canonical line specs.
6019 If ONE_LOCATION_ONLY is set and several matches are found for
6020 the given location, then automatically select the first match found
6021 instead of asking the user which instance should be returned. */
6023 struct symtabs_and_lines
6024 ada_sals_for_line (const char *filename
, int line_num
,
6025 int funfirstline
, char ***canonical
, int one_location_only
)
6027 struct symtabs_and_lines result
;
6028 struct objfile
*objfile
;
6030 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
6033 read_all_symtabs (filename
);
6036 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
6039 make_cleanup (free_current_contents
, &result
.sals
);
6041 ALL_SYMTABS (objfile
, s
)
6043 int ind
, target_line_num
;
6047 if (strcmp (s
->filename
, filename
) != 0)
6051 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
6052 if (target_line_num
== -1)
6059 find_next_line_in_linetable (LINETABLE (s
),
6060 target_line_num
, line_num
, ind
);
6065 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
6066 init_sal (&result
.sals
[result
.nelts
]);
6067 result
.sals
[result
.nelts
].line
= line_num
;
6068 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
6069 result
.sals
[result
.nelts
].symtab
= s
;
6072 adjust_pc_past_prologue (&result
.sals
[result
.nelts
].pc
);
6078 if (canonical
!= NULL
|| result
.nelts
> 1)
6081 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
6082 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
6083 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
6085 for (k
= 0; k
< result
.nelts
; k
+= 1)
6087 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
6088 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
6089 if (func_names
[k
] == NULL
)
6090 error ("Could not find function for one or more breakpoints.");
6093 /* Remove suppressed names, unless all are suppressed. */
6094 for (j
= 0; j
< result
.nelts
; j
+= 1)
6095 if (!is_suppressed_name (func_names
[j
]))
6097 /* At least one name is unsuppressed, so remove all
6098 suppressed names. */
6099 for (k
= n
= 0; k
< result
.nelts
; k
+= 1)
6100 if (!is_suppressed_name (func_names
[k
]))
6102 func_names
[n
] = func_names
[k
];
6103 result
.sals
[n
] = result
.sals
[k
];
6110 if (result
.nelts
> 1)
6112 if (one_location_only
)
6114 /* Automatically select the first of all possible choices. */
6120 printf_unfiltered ("[0] cancel\n");
6121 if (result
.nelts
> 1)
6122 printf_unfiltered ("[1] all\n");
6123 for (k
= 0; k
< result
.nelts
; k
+= 1)
6124 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
6125 ada_decode (func_names
[k
]));
6127 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
6128 result
.nelts
> 1, "instance-choice");
6131 for (k
= 0; k
< n
; k
+= 1)
6133 result
.sals
[k
] = result
.sals
[choices
[k
]];
6134 func_names
[k
] = func_names
[choices
[k
]];
6139 if (canonical
!= NULL
&& result
.nelts
== 0)
6141 else if (canonical
!= NULL
)
6143 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
6144 make_cleanup (xfree
, *canonical
);
6145 for (k
= 0; k
< result
.nelts
; k
+= 1)
6148 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
6149 if ((*canonical
)[k
] == NULL
)
6150 error ("Could not locate one or more breakpoints.");
6151 make_cleanup (xfree
, (*canonical
)[k
]);
6156 if (result
.nelts
== 0)
6158 do_cleanups (old_chain
);
6162 discard_cleanups (old_chain
);
6167 /* A canonical line specification of the form FILE:NAME:LINENUM for
6168 symbol table and line data SAL. NULL if insufficient
6169 information. The caller is responsible for releasing any space
6173 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
6177 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
6180 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
6181 + sizeof (sal
.line
) * 3 + 3);
6182 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
6187 /* Exception-related */
6190 ada_is_exception_sym (struct symbol
*sym
)
6192 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
6194 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
6195 && SYMBOL_CLASS (sym
) != LOC_BLOCK
6196 && SYMBOL_CLASS (sym
) != LOC_CONST
6197 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
6200 /* Return type of Ada breakpoint associated with bp_stat:
6201 0 if not an Ada-specific breakpoint, 1 for break on specific exception,
6202 2 for break on unhandled exception, 3 for assert. */
6205 ada_exception_breakpoint_type (bpstat bs
)
6207 return ((!bs
|| !bs
->breakpoint_at
) ? 0
6208 : bs
->breakpoint_at
->break_on_exception
);
6211 /* True iff FRAME is very likely to be that of a function that is
6212 part of the runtime system. This is all very heuristic, but is
6213 intended to be used as advice as to what frames are uninteresting
6217 is_known_support_routine (struct frame_info
*frame
)
6219 struct frame_info
*next_frame
= get_next_frame (frame
);
6220 /* If frame is not innermost, that normally means that frame->pc
6221 points to *after* the call instruction, and we want to get the line
6222 containing the call, never the next line. But if the next frame is
6223 a signal_handler_caller or a dummy frame, then the next frame was
6224 not entered as the result of a call, and we want to get the line
6225 containing frame->pc. */
6226 const int pc_is_after_call
=
6228 && get_frame_type (next_frame
) != SIGTRAMP_FRAME
6229 && get_frame_type (next_frame
) != DUMMY_FRAME
;
6230 struct symtab_and_line sal
6231 = find_pc_line (get_frame_pc (frame
), pc_is_after_call
);
6237 1. The symtab is null (indicating no debugging symbols)
6238 2. The symtab's filename does not exist.
6239 3. The object file's name is one of the standard libraries.
6240 4. The symtab's file name has the form of an Ada library source file.
6241 5. The function at frame's PC has a GNAT-compiler-generated name. */
6243 if (sal
.symtab
== NULL
)
6246 /* On some systems (e.g. VxWorks), the kernel contains debugging
6247 symbols; in this case, the filename referenced by these symbols
6250 if (stat (sal
.symtab
->filename
, &st
))
6253 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
6255 re_comp (known_runtime_file_name_patterns
[i
]);
6256 if (re_exec (sal
.symtab
->filename
))
6259 if (sal
.symtab
->objfile
!= NULL
)
6261 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
6263 re_comp (known_runtime_file_name_patterns
[i
]);
6264 if (re_exec (sal
.symtab
->objfile
->name
))
6269 /* If the frame PC points after the call instruction, then we need to
6270 decrement it in order to search for the function associated to this
6271 PC. Otherwise, if the associated call was the last instruction of
6272 the function, we might either find the wrong function or even fail
6273 during the function name lookup. */
6274 if (pc_is_after_call
)
6275 func_name
= function_name_from_pc (get_frame_pc (frame
) - 1);
6277 func_name
= function_name_from_pc (get_frame_pc (frame
));
6279 if (func_name
== NULL
)
6282 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
6284 re_comp (known_auxiliary_function_name_patterns
[i
]);
6285 if (re_exec (func_name
))
6292 /* Find the first frame that contains debugging information and that is not
6293 part of the Ada run-time, starting from FI and moving upward. */
6296 ada_find_printable_frame (struct frame_info
*fi
)
6298 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
6300 if (!is_known_support_routine (fi
))
6309 /* Name found for exception associated with last bpstat sent to
6310 ada_adjust_exception_stop. Set to the null string if that bpstat
6311 did not correspond to an Ada exception or no name could be found. */
6313 static char last_exception_name
[256];
6315 /* If BS indicates a stop in an Ada exception, try to go up to a frame
6316 that will be meaningful to the user, and save the name of the last
6317 exception (truncated, if necessary) in last_exception_name. */
6320 ada_adjust_exception_stop (bpstat bs
)
6323 struct frame_info
*fi
;
6325 char *selected_frame_func
;
6328 last_exception_name
[0] = '\0';
6329 fi
= get_selected_frame ();
6330 selected_frame_func
= function_name_from_pc (get_frame_pc (fi
));
6332 switch (ada_exception_breakpoint_type (bs
))
6339 /* Unhandled exceptions. Select the frame corresponding to
6340 ada.exceptions.process_raise_exception. This frame is at
6341 least 2 levels up, so we simply skip the first 2 frames
6342 without checking the name of their associated function. */
6343 for (frame_level
= 0; frame_level
< 2; frame_level
+= 1)
6345 fi
= get_prev_frame (fi
);
6348 const char *func_name
= function_name_from_pc (get_frame_pc (fi
));
6349 if (func_name
!= NULL
6350 && strcmp (func_name
, process_raise_exception_name
) == 0)
6351 break; /* We found the frame we were looking for... */
6352 fi
= get_prev_frame (fi
);
6360 addr
= parse_and_eval_address ("e.full_name");
6363 read_memory (addr
, last_exception_name
, sizeof (last_exception_name
) - 1);
6364 last_exception_name
[sizeof (last_exception_name
) - 1] = '\0';
6365 ada_find_printable_frame (get_selected_frame ());
6368 /* Output Ada exception name (if any) associated with last call to
6369 ada_adjust_exception_stop. */
6372 ada_print_exception_stop (bpstat bs
)
6374 if (last_exception_name
[0] != '\000')
6376 ui_out_text (uiout
, last_exception_name
);
6377 ui_out_text (uiout
, " at ");
6381 /* Parses the CONDITION string associated with a breakpoint exception
6382 to get the name of the exception on which the breakpoint has been
6383 set. The returned string needs to be deallocated after use. */
6386 exception_name_from_cond (const char *condition
)
6388 char *start
, *end
, *exception_name
;
6389 int exception_name_len
;
6391 start
= strrchr (condition
, '&') + 1;
6392 end
= strchr (start
, ')') - 1;
6393 exception_name_len
= end
- start
+ 1;
6396 (char *) xmalloc ((exception_name_len
+ 1) * sizeof (char));
6397 sprintf (exception_name
, "%.*s", exception_name_len
, start
);
6399 return exception_name
;
6402 /* Print Ada-specific exception information about B, other than task
6403 clause. Return non-zero iff B was an Ada exception breakpoint. */
6406 ada_print_exception_breakpoint_nontask (struct breakpoint
*b
)
6408 if (b
->break_on_exception
== 1)
6410 if (b
->cond_string
) /* the breakpoint is on a specific exception. */
6412 char *exception_name
= exception_name_from_cond (b
->cond_string
);
6414 make_cleanup (xfree
, exception_name
);
6416 ui_out_text (uiout
, "on ");
6417 if (ui_out_is_mi_like_p (uiout
))
6418 ui_out_field_string (uiout
, "exception", exception_name
);
6421 ui_out_text (uiout
, "exception ");
6422 ui_out_text (uiout
, exception_name
);
6423 ui_out_text (uiout
, " ");
6427 ui_out_text (uiout
, "on all exceptions");
6429 else if (b
->break_on_exception
== 2)
6430 ui_out_text (uiout
, "on unhandled exception");
6431 else if (b
->break_on_exception
== 3)
6432 ui_out_text (uiout
, "on assert failure");
6438 /* Print task identifier for breakpoint B, if it is an Ada-specific
6439 breakpoint with non-zero tasking information. */
6442 ada_print_exception_breakpoint_task (struct breakpoint
*b
)
6446 ui_out_text (uiout
, " task ");
6447 ui_out_field_int (uiout
, "task", b
->task
);
6451 /* Cause the appropriate error if no appropriate runtime symbol is
6452 found to set a breakpoint, using ERR_DESC to describe the
6456 error_breakpoint_runtime_sym_not_found (const char *err_desc
)
6458 /* If we are not debugging an Ada program, we can not put exception
6461 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
6462 error ("Unable to break on %s. Is this an Ada main program?", err_desc
);
6464 /* If the symbol does not exist, then check that the program is
6465 already started, to make sure that shared libraries have been
6466 loaded. If it is not started, this may mean that the symbol is
6467 in a shared library. */
6469 if (ptid_get_pid (inferior_ptid
) == 0)
6470 error ("Unable to break on %s. Try to start the program first.",
6473 /* At this point, we know that we are debugging an Ada program and
6474 that the inferior has been started, but we still are not able to
6475 find the run-time symbols. That can mean that we are in
6476 configurable run time mode, or that a-except as been optimized
6477 out by the linker... In any case, at this point it is not worth
6478 supporting this feature. */
6480 error ("Cannot break on %s in this configuration.", err_desc
);
6483 /* Test if NAME is currently defined, and that either ALLOW_TRAMP or
6484 the symbol is not a shared-library trampoline. Return the result of
6488 is_runtime_sym_defined (const char *name
, int allow_tramp
)
6490 struct minimal_symbol
*msym
;
6492 msym
= lookup_minimal_symbol (name
, NULL
, NULL
);
6493 return (msym
!= NULL
&& msym
->type
!= mst_unknown
6494 && (allow_tramp
|| msym
->type
!= mst_solib_trampoline
));
6497 /* If ARG points to an Ada exception or assert breakpoint, rewrite
6498 into equivalent form. Return resulting argument string. Set
6499 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
6500 break on unhandled, 3 for assert, 0 otherwise. */
6503 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
6507 *break_on_exceptionp
= 0;
6508 if (current_language
->la_language
== language_ada
6509 && strncmp (arg
, "exception", 9) == 0
6510 && (arg
[9] == ' ' || arg
[9] == '\t' || arg
[9] == '\0'))
6512 char *tok
, *end_tok
;
6514 int has_exception_propagation
=
6515 is_runtime_sym_defined (raise_sym_name
, 1);
6517 *break_on_exceptionp
= 1;
6520 while (*tok
== ' ' || *tok
== '\t')
6525 while (*end_tok
!= ' ' && *end_tok
!= '\t' && *end_tok
!= '\000')
6528 toklen
= end_tok
- tok
;
6530 arg
= (char *) xmalloc (sizeof (longest_exception_template
) + toklen
);
6531 make_cleanup (xfree
, arg
);
6534 if (has_exception_propagation
)
6535 sprintf (arg
, "'%s'", raise_sym_name
);
6537 error_breakpoint_runtime_sym_not_found ("exception");
6539 else if (strncmp (tok
, "unhandled", toklen
) == 0)
6541 if (is_runtime_sym_defined (raise_unhandled_sym_name
, 1))
6542 sprintf (arg
, "'%s'", raise_unhandled_sym_name
);
6544 error_breakpoint_runtime_sym_not_found ("exception");
6546 *break_on_exceptionp
= 2;
6550 if (is_runtime_sym_defined (raise_sym_name
, 0))
6551 sprintf (arg
, "'%s' if long_integer(e) = long_integer(&%.*s)",
6552 raise_sym_name
, toklen
, tok
);
6554 error_breakpoint_runtime_sym_not_found ("specific exception");
6557 else if (current_language
->la_language
== language_ada
6558 && strncmp (arg
, "assert", 6) == 0
6559 && (arg
[6] == ' ' || arg
[6] == '\t' || arg
[6] == '\0'))
6561 char *tok
= arg
+ 6;
6563 if (!is_runtime_sym_defined (raise_assert_sym_name
, 1))
6564 error_breakpoint_runtime_sym_not_found ("failed assertion");
6566 *break_on_exceptionp
= 3;
6569 (char *) xmalloc (sizeof (raise_assert_sym_name
) + strlen (tok
) + 2);
6570 make_cleanup (xfree
, arg
);
6571 sprintf (arg
, "'%s'%s", raise_assert_sym_name
, tok
);
6575 #endif /* GNAT_GDB */
6579 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6580 to be invisible to users. */
6583 ada_is_ignored_field (struct type
*type
, int field_num
)
6585 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6589 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6590 return (name
== NULL
6591 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
6595 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6596 pointer or reference type whose ultimate target has a tag field. */
6599 ada_is_tagged_type (struct type
*type
, int refok
)
6601 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
6604 /* True iff TYPE represents the type of X'Tag */
6607 ada_is_tag_type (struct type
*type
)
6609 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6613 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6614 return (name
!= NULL
6615 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6619 /* The type of the tag on VAL. */
6622 ada_tag_type (struct value
*val
)
6624 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 1, 0, NULL
);
6627 /* The value of the tag on VAL. */
6630 ada_value_tag (struct value
*val
)
6632 return ada_value_struct_elt (val
, "_tag", "record");
6635 /* The value of the tag on the object of type TYPE whose contents are
6636 saved at VALADDR, if it is non-null, or is at memory address
6639 static struct value
*
6640 value_tag_from_contents_and_address (struct type
*type
, char *valaddr
,
6643 int tag_byte_offset
, dummy1
, dummy2
;
6644 struct type
*tag_type
;
6645 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6648 char *valaddr1
= (valaddr
== NULL
) ? NULL
: valaddr
+ tag_byte_offset
;
6649 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6651 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6656 static struct type
*
6657 type_from_tag (struct value
*tag
)
6659 const char *type_name
= ada_tag_name (tag
);
6660 if (type_name
!= NULL
)
6661 return ada_find_any_type (ada_encode (type_name
));
6671 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
6672 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
6673 The value stored in ARGS->name is valid until the next call to
6677 ada_tag_name_1 (void *args0
)
6679 struct tag_args
*args
= (struct tag_args
*) args0
;
6680 static char name
[1024];
6684 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
6687 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
6690 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6691 for (p
= name
; *p
!= '\0'; p
+= 1)
6698 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6702 ada_tag_name (struct value
*tag
)
6704 struct tag_args args
;
6705 if (!ada_is_tag_type (VALUE_TYPE (tag
)))
6709 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
6713 /* The parent type of TYPE, or NULL if none. */
6716 ada_parent_type (struct type
*type
)
6720 CHECK_TYPEDEF (type
);
6722 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6725 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6726 if (ada_is_parent_field (type
, i
))
6727 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
6732 /* True iff field number FIELD_NUM of structure type TYPE contains the
6733 parent-type (inherited) fields of a derived type. Assumes TYPE is
6734 a structure type with at least FIELD_NUM+1 fields. */
6737 ada_is_parent_field (struct type
*type
, int field_num
)
6739 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
6740 return (name
!= NULL
6741 && (strncmp (name
, "PARENT", 6) == 0
6742 || strncmp (name
, "_parent", 7) == 0));
6745 /* True iff field number FIELD_NUM of structure type TYPE is a
6746 transparent wrapper field (which should be silently traversed when doing
6747 field selection and flattened when printing). Assumes TYPE is a
6748 structure type with at least FIELD_NUM+1 fields. Such fields are always
6752 ada_is_wrapper_field (struct type
*type
, int field_num
)
6754 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6755 return (name
!= NULL
6756 && (strncmp (name
, "PARENT", 6) == 0
6757 || strcmp (name
, "REP") == 0
6758 || strncmp (name
, "_parent", 7) == 0
6759 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6762 /* True iff field number FIELD_NUM of structure or union type TYPE
6763 is a variant wrapper. Assumes TYPE is a structure type with at least
6764 FIELD_NUM+1 fields. */
6767 ada_is_variant_part (struct type
*type
, int field_num
)
6769 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6770 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6771 || (is_dynamic_field (type
, field_num
)
6772 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
6773 == TYPE_CODE_UNION
)));
6776 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6777 whose discriminants are contained in the record type OUTER_TYPE,
6778 returns the type of the controlling discriminant for the variant. */
6781 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6783 char *name
= ada_variant_discrim_name (var_type
);
6785 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
6787 return builtin_type_int
;
6792 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6793 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6794 represents a 'when others' clause; otherwise 0. */
6797 ada_is_others_clause (struct type
*type
, int field_num
)
6799 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6800 return (name
!= NULL
&& name
[0] == 'O');
6803 /* Assuming that TYPE0 is the type of the variant part of a record,
6804 returns the name of the discriminant controlling the variant.
6805 The value is valid until the next call to ada_variant_discrim_name. */
6808 ada_variant_discrim_name (struct type
*type0
)
6810 static char *result
= NULL
;
6811 static size_t result_len
= 0;
6814 const char *discrim_end
;
6815 const char *discrim_start
;
6817 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6818 type
= TYPE_TARGET_TYPE (type0
);
6822 name
= ada_type_name (type
);
6824 if (name
== NULL
|| name
[0] == '\000')
6827 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6830 if (strncmp (discrim_end
, "___XVN", 6) == 0)
6833 if (discrim_end
== name
)
6836 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6839 if (discrim_start
== name
+ 1)
6841 if ((discrim_start
> name
+ 3
6842 && strncmp (discrim_start
- 3, "___", 3) == 0)
6843 || discrim_start
[-1] == '.')
6847 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6848 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6849 result
[discrim_end
- discrim_start
] = '\0';
6853 /* Scan STR for a subtype-encoded number, beginning at position K.
6854 Put the position of the character just past the number scanned in
6855 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6856 Return 1 if there was a valid number at the given position, and 0
6857 otherwise. A "subtype-encoded" number consists of the absolute value
6858 in decimal, followed by the letter 'm' to indicate a negative number.
6859 Assumes 0m does not occur. */
6862 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6866 if (!isdigit (str
[k
]))
6869 /* Do it the hard way so as not to make any assumption about
6870 the relationship of unsigned long (%lu scan format code) and
6873 while (isdigit (str
[k
]))
6875 RU
= RU
* 10 + (str
[k
] - '0');
6882 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6888 /* NOTE on the above: Technically, C does not say what the results of
6889 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6890 number representable as a LONGEST (although either would probably work
6891 in most implementations). When RU>0, the locution in the then branch
6892 above is always equivalent to the negative of RU. */
6899 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6900 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6901 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6904 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6906 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6919 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6928 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6929 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6931 if (val
>= L
&& val
<= U
)
6943 /* FIXME: Lots of redundancy below. Try to consolidate. */
6945 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6946 ARG_TYPE, extract and return the value of one of its (non-static)
6947 fields. FIELDNO says which field. Differs from value_primitive_field
6948 only in that it can handle packed values of arbitrary type. */
6950 static struct value
*
6951 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6952 struct type
*arg_type
)
6956 CHECK_TYPEDEF (arg_type
);
6957 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
6959 /* Handle packed fields. */
6961 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
6963 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6964 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6966 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
6967 offset
+ bit_pos
/ 8,
6968 bit_pos
% 8, bit_size
, type
);
6971 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6974 /* Find field with name NAME in object of type TYPE. If found, return 1
6975 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
6976 OFFSET + the byte offset of the field within an object of that type,
6977 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
6978 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
6979 Looks inside wrappers for the field. Returns 0 if field not
6982 find_struct_field (char *name
, struct type
*type
, int offset
,
6983 struct type
**field_type_p
,
6984 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
6988 CHECK_TYPEDEF (type
);
6989 *field_type_p
= NULL
;
6990 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
6992 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
6994 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6995 int fld_offset
= offset
+ bit_pos
/ 8;
6996 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6998 if (t_field_name
== NULL
)
7001 else if (field_name_match (t_field_name
, name
))
7003 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
7004 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
7005 *byte_offset_p
= fld_offset
;
7006 *bit_offset_p
= bit_pos
% 8;
7007 *bit_size_p
= bit_size
;
7010 else if (ada_is_wrapper_field (type
, i
))
7012 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
7013 field_type_p
, byte_offset_p
, bit_offset_p
,
7017 else if (ada_is_variant_part (type
, i
))
7020 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7022 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7024 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
7026 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7027 field_type_p
, byte_offset_p
,
7028 bit_offset_p
, bit_size_p
))
7038 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7039 and search in it assuming it has (class) type TYPE.
7040 If found, return value, else return NULL.
7042 Searches recursively through wrapper fields (e.g., '_parent'). */
7044 static struct value
*
7045 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
7049 CHECK_TYPEDEF (type
);
7051 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
7053 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7055 if (t_field_name
== NULL
)
7058 else if (field_name_match (t_field_name
, name
))
7059 return ada_value_primitive_field (arg
, offset
, i
, type
);
7061 else if (ada_is_wrapper_field (type
, i
))
7063 struct value
*v
= /* Do not let indent join lines here. */
7064 ada_search_struct_field (name
, arg
,
7065 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7066 TYPE_FIELD_TYPE (type
, i
));
7071 else if (ada_is_variant_part (type
, i
))
7074 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7075 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7077 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7079 struct value
*v
= ada_search_struct_field
/* Force line break. */
7081 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7082 TYPE_FIELD_TYPE (field_type
, j
));
7091 /* Given ARG, a value of type (pointer or reference to a)*
7092 structure/union, extract the component named NAME from the ultimate
7093 target structure/union and return it as a value with its
7094 appropriate type. If ARG is a pointer or reference and the field
7095 is not packed, returns a reference to the field, otherwise the
7096 value of the field (an lvalue if ARG is an lvalue).
7098 The routine searches for NAME among all members of the structure itself
7099 and (recursively) among all members of any wrapper members
7102 ERR is a name (for use in error messages) that identifies the class
7103 of entity that ARG is supposed to be. ERR may be null, indicating
7104 that on error, the function simply returns NULL, and does not
7105 throw an error. (FIXME: True only if ARG is a pointer or reference
7109 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
7111 struct type
*t
, *t1
;
7115 t1
= t
= check_typedef (VALUE_TYPE (arg
));
7116 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7118 t1
= TYPE_TARGET_TYPE (t
);
7124 error ("Bad value type in a %s.", err
);
7127 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7134 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7136 t1
= TYPE_TARGET_TYPE (t
);
7142 error ("Bad value type in a %s.", err
);
7145 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7147 arg
= value_ind (arg
);
7154 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7159 error ("Attempt to extract a component of a value that is not a %s.",
7164 v
= ada_search_struct_field (name
, arg
, 0, t
);
7167 int bit_offset
, bit_size
, byte_offset
;
7168 struct type
*field_type
;
7171 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7172 address
= value_as_address (arg
);
7174 address
= unpack_pointer (t
, VALUE_CONTENTS (arg
));
7176 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
7177 if (find_struct_field (name
, t1
, 0,
7178 &field_type
, &byte_offset
, &bit_offset
,
7183 arg
= ada_value_ind (arg
);
7184 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7185 bit_offset
, bit_size
,
7189 v
= value_from_pointer (lookup_reference_type (field_type
),
7190 address
+ byte_offset
);
7194 if (v
== NULL
&& err
!= NULL
)
7195 error ("There is no member named %s.", name
);
7200 /* Given a type TYPE, look up the type of the component of type named NAME.
7201 If DISPP is non-null, add its byte displacement from the beginning of a
7202 structure (pointed to by a value) of type TYPE to *DISPP (does not
7203 work for packed fields).
7205 Matches any field whose name has NAME as a prefix, possibly
7208 TYPE can be either a struct or union. If REFOK, TYPE may also
7209 be a (pointer or reference)+ to a struct or union, and the
7210 ultimate target type will be searched.
7212 Looks recursively into variant clauses and parent types.
7214 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7215 TYPE is not a type of the right kind. */
7217 static struct type
*
7218 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
7219 int noerr
, int *dispp
)
7226 if (refok
&& type
!= NULL
)
7229 CHECK_TYPEDEF (type
);
7230 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7231 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7233 type
= TYPE_TARGET_TYPE (type
);
7237 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7238 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7244 target_terminal_ours ();
7245 gdb_flush (gdb_stdout
);
7246 fprintf_unfiltered (gdb_stderr
, "Type ");
7248 fprintf_unfiltered (gdb_stderr
, "(null)");
7250 type_print (type
, "", gdb_stderr
, -1);
7251 error (" is not a structure or union type");
7255 type
= to_static_fixed_type (type
);
7257 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7259 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7263 if (t_field_name
== NULL
)
7266 else if (field_name_match (t_field_name
, name
))
7269 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
7270 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
7273 else if (ada_is_wrapper_field (type
, i
))
7276 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7281 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7286 else if (ada_is_variant_part (type
, i
))
7289 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7291 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7294 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
7299 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7310 target_terminal_ours ();
7311 gdb_flush (gdb_stdout
);
7312 fprintf_unfiltered (gdb_stderr
, "Type ");
7313 type_print (type
, "", gdb_stderr
, -1);
7314 fprintf_unfiltered (gdb_stderr
, " has no component named ");
7315 error ("%s", name
== NULL
? "<null>" : name
);
7321 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7322 within a value of type OUTER_TYPE that is stored in GDB at
7323 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7324 numbering from 0) is applicable. Returns -1 if none are. */
7327 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7328 char *outer_valaddr
)
7333 struct type
*discrim_type
;
7334 char *discrim_name
= ada_variant_discrim_name (var_type
);
7335 LONGEST discrim_val
;
7339 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
7340 if (discrim_type
== NULL
)
7342 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
7345 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7347 if (ada_is_others_clause (var_type
, i
))
7349 else if (ada_in_variant (discrim_val
, var_type
, i
))
7353 return others_clause
;
7358 /* Dynamic-Sized Records */
7360 /* Strategy: The type ostensibly attached to a value with dynamic size
7361 (i.e., a size that is not statically recorded in the debugging
7362 data) does not accurately reflect the size or layout of the value.
7363 Our strategy is to convert these values to values with accurate,
7364 conventional types that are constructed on the fly. */
7366 /* There is a subtle and tricky problem here. In general, we cannot
7367 determine the size of dynamic records without its data. However,
7368 the 'struct value' data structure, which GDB uses to represent
7369 quantities in the inferior process (the target), requires the size
7370 of the type at the time of its allocation in order to reserve space
7371 for GDB's internal copy of the data. That's why the
7372 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7373 rather than struct value*s.
7375 However, GDB's internal history variables ($1, $2, etc.) are
7376 struct value*s containing internal copies of the data that are not, in
7377 general, the same as the data at their corresponding addresses in
7378 the target. Fortunately, the types we give to these values are all
7379 conventional, fixed-size types (as per the strategy described
7380 above), so that we don't usually have to perform the
7381 'to_fixed_xxx_type' conversions to look at their values.
7382 Unfortunately, there is one exception: if one of the internal
7383 history variables is an array whose elements are unconstrained
7384 records, then we will need to create distinct fixed types for each
7385 element selected. */
7387 /* The upshot of all of this is that many routines take a (type, host
7388 address, target address) triple as arguments to represent a value.
7389 The host address, if non-null, is supposed to contain an internal
7390 copy of the relevant data; otherwise, the program is to consult the
7391 target at the target address. */
7393 /* Assuming that VAL0 represents a pointer value, the result of
7394 dereferencing it. Differs from value_ind in its treatment of
7395 dynamic-sized types. */
7398 ada_value_ind (struct value
*val0
)
7400 struct value
*val
= unwrap_value (value_ind (val0
));
7401 return ada_to_fixed_value (val
);
7404 /* The value resulting from dereferencing any "reference to"
7405 qualifiers on VAL0. */
7407 static struct value
*
7408 ada_coerce_ref (struct value
*val0
)
7410 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
7412 struct value
*val
= val0
;
7414 val
= unwrap_value (val
);
7415 return ada_to_fixed_value (val
);
7421 /* Return OFF rounded upward if necessary to a multiple of
7422 ALIGNMENT (a power of 2). */
7425 align_value (unsigned int off
, unsigned int alignment
)
7427 return (off
+ alignment
- 1) & ~(alignment
- 1);
7430 /* Return the bit alignment required for field #F of template type TYPE. */
7433 field_alignment (struct type
*type
, int f
)
7435 const char *name
= TYPE_FIELD_NAME (type
, f
);
7436 int len
= (name
== NULL
) ? 0 : strlen (name
);
7439 if (!isdigit (name
[len
- 1]))
7442 if (isdigit (name
[len
- 2]))
7443 align_offset
= len
- 2;
7445 align_offset
= len
- 1;
7447 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
7448 return TARGET_CHAR_BIT
;
7450 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7453 /* Find a symbol named NAME. Ignores ambiguity. */
7456 ada_find_any_symbol (const char *name
)
7460 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7461 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7464 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7468 /* Find a type named NAME. Ignores ambiguity. */
7471 ada_find_any_type (const char *name
)
7473 struct symbol
*sym
= ada_find_any_symbol (name
);
7476 return SYMBOL_TYPE (sym
);
7481 /* Given a symbol NAME and its associated BLOCK, search all symbols
7482 for its ___XR counterpart, which is the ``renaming'' symbol
7483 associated to NAME. Return this symbol if found, return
7487 ada_find_renaming_symbol (const char *name
, struct block
*block
)
7489 const struct symbol
*function_sym
= block_function (block
);
7492 if (function_sym
!= NULL
)
7494 /* If the symbol is defined inside a function, NAME is not fully
7495 qualified. This means we need to prepend the function name
7496 as well as adding the ``___XR'' suffix to build the name of
7497 the associated renaming symbol. */
7498 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
7499 const int function_name_len
= strlen (function_name
);
7500 const int rename_len
= function_name_len
+ 2 /* "__" */
7501 + strlen (name
) + 6 /* "___XR\0" */ ;
7503 /* Library-level functions are a special case, as GNAT adds
7504 a ``_ada_'' prefix to the function name to avoid namespace
7505 pollution. However, the renaming symbol themselves do not
7506 have this prefix, so we need to skip this prefix if present. */
7507 if (function_name_len
> 5 /* "_ada_" */
7508 && strstr (function_name
, "_ada_") == function_name
)
7509 function_name
= function_name
+ 5;
7511 rename
= (char *) alloca (rename_len
* sizeof (char));
7512 sprintf (rename
, "%s__%s___XR", function_name
, name
);
7516 const int rename_len
= strlen (name
) + 6;
7517 rename
= (char *) alloca (rename_len
* sizeof (char));
7518 sprintf (rename
, "%s___XR", name
);
7521 return ada_find_any_symbol (rename
);
7524 /* Because of GNAT encoding conventions, several GDB symbols may match a
7525 given type name. If the type denoted by TYPE0 is to be preferred to
7526 that of TYPE1 for purposes of type printing, return non-zero;
7527 otherwise return 0. */
7530 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7534 else if (type0
== NULL
)
7536 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
7538 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
7540 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
7542 else if (ada_is_packed_array_type (type0
))
7544 else if (ada_is_array_descriptor_type (type0
)
7545 && !ada_is_array_descriptor_type (type1
))
7547 else if (ada_renaming_type (type0
) != NULL
7548 && ada_renaming_type (type1
) == NULL
)
7553 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7554 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7557 ada_type_name (struct type
*type
)
7561 else if (TYPE_NAME (type
) != NULL
)
7562 return TYPE_NAME (type
);
7564 return TYPE_TAG_NAME (type
);
7567 /* Find a parallel type to TYPE whose name is formed by appending
7568 SUFFIX to the name of TYPE. */
7571 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7574 static size_t name_len
= 0;
7576 char *typename
= ada_type_name (type
);
7578 if (typename
== NULL
)
7581 len
= strlen (typename
);
7583 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
7585 strcpy (name
, typename
);
7586 strcpy (name
+ len
, suffix
);
7588 return ada_find_any_type (name
);
7592 /* If TYPE is a variable-size record type, return the corresponding template
7593 type describing its fields. Otherwise, return NULL. */
7595 static struct type
*
7596 dynamic_template_type (struct type
*type
)
7598 CHECK_TYPEDEF (type
);
7600 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
7601 || ada_type_name (type
) == NULL
)
7605 int len
= strlen (ada_type_name (type
));
7606 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7609 return ada_find_parallel_type (type
, "___XVE");
7613 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7614 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7617 is_dynamic_field (struct type
*templ_type
, int field_num
)
7619 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7621 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
7622 && strstr (name
, "___XVL") != NULL
;
7625 /* The index of the variant field of TYPE, or -1 if TYPE does not
7626 represent a variant record type. */
7629 variant_field_index (struct type
*type
)
7633 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
7636 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
7638 if (ada_is_variant_part (type
, f
))
7644 /* A record type with no fields. */
7646 static struct type
*
7647 empty_record (struct objfile
*objfile
)
7649 struct type
*type
= alloc_type (objfile
);
7650 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
7651 TYPE_NFIELDS (type
) = 0;
7652 TYPE_FIELDS (type
) = NULL
;
7653 TYPE_NAME (type
) = "<empty>";
7654 TYPE_TAG_NAME (type
) = NULL
;
7655 TYPE_FLAGS (type
) = 0;
7656 TYPE_LENGTH (type
) = 0;
7660 /* An ordinary record type (with fixed-length fields) that describes
7661 the value of type TYPE at VALADDR or ADDRESS (see comments at
7662 the beginning of this section) VAL according to GNAT conventions.
7663 DVAL0 should describe the (portion of a) record that contains any
7664 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
7665 an outer-level type (i.e., as opposed to a branch of a variant.) A
7666 variant field (unless unchecked) is replaced by a particular branch
7669 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7670 length are not statically known are discarded. As a consequence,
7671 VALADDR, ADDRESS and DVAL0 are ignored.
7673 NOTE: Limitations: For now, we assume that dynamic fields and
7674 variants occupy whole numbers of bytes. However, they need not be
7678 ada_template_to_fixed_record_type_1 (struct type
*type
, char *valaddr
,
7679 CORE_ADDR address
, struct value
*dval0
,
7680 int keep_dynamic_fields
)
7682 struct value
*mark
= value_mark ();
7685 int nfields
, bit_len
;
7688 int fld_bit_len
, bit_incr
;
7691 /* Compute the number of fields in this record type that are going
7692 to be processed: unless keep_dynamic_fields, this includes only
7693 fields whose position and length are static will be processed. */
7694 if (keep_dynamic_fields
)
7695 nfields
= TYPE_NFIELDS (type
);
7699 while (nfields
< TYPE_NFIELDS (type
)
7700 && !ada_is_variant_part (type
, nfields
)
7701 && !is_dynamic_field (type
, nfields
))
7705 rtype
= alloc_type (TYPE_OBJFILE (type
));
7706 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7707 INIT_CPLUS_SPECIFIC (rtype
);
7708 TYPE_NFIELDS (rtype
) = nfields
;
7709 TYPE_FIELDS (rtype
) = (struct field
*)
7710 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7711 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
7712 TYPE_NAME (rtype
) = ada_type_name (type
);
7713 TYPE_TAG_NAME (rtype
) = NULL
;
7714 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
7720 for (f
= 0; f
< nfields
; f
+= 1)
7722 off
= align_value (off
, field_alignment (type
, f
))
7723 + TYPE_FIELD_BITPOS (type
, f
);
7724 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
7725 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7727 if (ada_is_variant_part (type
, f
))
7730 fld_bit_len
= bit_incr
= 0;
7732 else if (is_dynamic_field (type
, f
))
7735 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7739 TYPE_FIELD_TYPE (rtype
, f
) =
7742 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
7743 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7744 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7745 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7746 bit_incr
= fld_bit_len
=
7747 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
7751 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
7752 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7753 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7754 bit_incr
= fld_bit_len
=
7755 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7757 bit_incr
= fld_bit_len
=
7758 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
7760 if (off
+ fld_bit_len
> bit_len
)
7761 bit_len
= off
+ fld_bit_len
;
7763 TYPE_LENGTH (rtype
) =
7764 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7767 /* We handle the variant part, if any, at the end because of certain
7768 odd cases in which it is re-ordered so as NOT the last field of
7769 the record. This can happen in the presence of representation
7771 if (variant_field
>= 0)
7773 struct type
*branch_type
;
7775 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7778 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7783 to_fixed_variant_branch_type
7784 (TYPE_FIELD_TYPE (type
, variant_field
),
7785 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7786 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7787 if (branch_type
== NULL
)
7789 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
7790 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7791 TYPE_NFIELDS (rtype
) -= 1;
7795 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7796 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7798 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
7800 if (off
+ fld_bit_len
> bit_len
)
7801 bit_len
= off
+ fld_bit_len
;
7802 TYPE_LENGTH (rtype
) =
7803 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7807 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
7809 value_free_to_mark (mark
);
7810 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7811 error ("record type with dynamic size is larger than varsize-limit");
7815 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7818 static struct type
*
7819 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
7820 CORE_ADDR address
, struct value
*dval0
)
7822 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7826 /* An ordinary record type in which ___XVL-convention fields and
7827 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7828 static approximations, containing all possible fields. Uses
7829 no runtime values. Useless for use in values, but that's OK,
7830 since the results are used only for type determinations. Works on both
7831 structs and unions. Representation note: to save space, we memorize
7832 the result of this function in the TYPE_TARGET_TYPE of the
7835 static struct type
*
7836 template_to_static_fixed_type (struct type
*type0
)
7842 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7843 return TYPE_TARGET_TYPE (type0
);
7845 nfields
= TYPE_NFIELDS (type0
);
7848 for (f
= 0; f
< nfields
; f
+= 1)
7850 struct type
*field_type
= CHECK_TYPEDEF (TYPE_FIELD_TYPE (type0
, f
));
7851 struct type
*new_type
;
7853 if (is_dynamic_field (type0
, f
))
7854 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7856 new_type
= to_static_fixed_type (field_type
);
7857 if (type
== type0
&& new_type
!= field_type
)
7859 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
7860 TYPE_CODE (type
) = TYPE_CODE (type0
);
7861 INIT_CPLUS_SPECIFIC (type
);
7862 TYPE_NFIELDS (type
) = nfields
;
7863 TYPE_FIELDS (type
) = (struct field
*)
7864 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7865 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7866 sizeof (struct field
) * nfields
);
7867 TYPE_NAME (type
) = ada_type_name (type0
);
7868 TYPE_TAG_NAME (type
) = NULL
;
7869 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
7870 TYPE_LENGTH (type
) = 0;
7872 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7873 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7878 /* Given an object of type TYPE whose contents are at VALADDR and
7879 whose address in memory is ADDRESS, returns a revision of TYPE --
7880 a non-dynamic-sized record with a variant part -- in which
7881 the variant part is replaced with the appropriate branch. Looks
7882 for discriminant values in DVAL0, which can be NULL if the record
7883 contains the necessary discriminant values. */
7885 static struct type
*
7886 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
7887 CORE_ADDR address
, struct value
*dval0
)
7889 struct value
*mark
= value_mark ();
7892 struct type
*branch_type
;
7893 int nfields
= TYPE_NFIELDS (type
);
7894 int variant_field
= variant_field_index (type
);
7896 if (variant_field
== -1)
7900 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7904 rtype
= alloc_type (TYPE_OBJFILE (type
));
7905 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7906 INIT_CPLUS_SPECIFIC (rtype
);
7907 TYPE_NFIELDS (rtype
) = nfields
;
7908 TYPE_FIELDS (rtype
) =
7909 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7910 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7911 sizeof (struct field
) * nfields
);
7912 TYPE_NAME (rtype
) = ada_type_name (type
);
7913 TYPE_TAG_NAME (rtype
) = NULL
;
7914 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
7915 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7917 branch_type
= to_fixed_variant_branch_type
7918 (TYPE_FIELD_TYPE (type
, variant_field
),
7919 cond_offset_host (valaddr
,
7920 TYPE_FIELD_BITPOS (type
, variant_field
)
7922 cond_offset_target (address
,
7923 TYPE_FIELD_BITPOS (type
, variant_field
)
7924 / TARGET_CHAR_BIT
), dval
);
7925 if (branch_type
== NULL
)
7928 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7929 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7930 TYPE_NFIELDS (rtype
) -= 1;
7934 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7935 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7936 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7937 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7939 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7941 value_free_to_mark (mark
);
7945 /* An ordinary record type (with fixed-length fields) that describes
7946 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7947 beginning of this section]. Any necessary discriminants' values
7948 should be in DVAL, a record value; it may be NULL if the object
7949 at ADDR itself contains any necessary discriminant values.
7950 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7951 values from the record are needed. Except in the case that DVAL,
7952 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7953 unchecked) is replaced by a particular branch of the variant.
7955 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7956 is questionable and may be removed. It can arise during the
7957 processing of an unconstrained-array-of-record type where all the
7958 variant branches have exactly the same size. This is because in
7959 such cases, the compiler does not bother to use the XVS convention
7960 when encoding the record. I am currently dubious of this
7961 shortcut and suspect the compiler should be altered. FIXME. */
7963 static struct type
*
7964 to_fixed_record_type (struct type
*type0
, char *valaddr
,
7965 CORE_ADDR address
, struct value
*dval
)
7967 struct type
*templ_type
;
7969 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
7972 templ_type
= dynamic_template_type (type0
);
7974 if (templ_type
!= NULL
)
7975 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7976 else if (variant_field_index (type0
) >= 0)
7978 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7980 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7985 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
7991 /* An ordinary record type (with fixed-length fields) that describes
7992 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7993 union type. Any necessary discriminants' values should be in DVAL,
7994 a record value. That is, this routine selects the appropriate
7995 branch of the union at ADDR according to the discriminant value
7996 indicated in the union's type name. */
7998 static struct type
*
7999 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
8000 CORE_ADDR address
, struct value
*dval
)
8003 struct type
*templ_type
;
8004 struct type
*var_type
;
8006 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
8007 var_type
= TYPE_TARGET_TYPE (var_type0
);
8009 var_type
= var_type0
;
8011 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
8013 if (templ_type
!= NULL
)
8014 var_type
= templ_type
;
8017 ada_which_variant_applies (var_type
,
8018 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
8021 return empty_record (TYPE_OBJFILE (var_type
));
8022 else if (is_dynamic_field (var_type
, which
))
8023 return to_fixed_record_type
8024 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
8025 valaddr
, address
, dval
);
8026 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
8028 to_fixed_record_type
8029 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
8031 return TYPE_FIELD_TYPE (var_type
, which
);
8034 /* Assuming that TYPE0 is an array type describing the type of a value
8035 at ADDR, and that DVAL describes a record containing any
8036 discriminants used in TYPE0, returns a type for the value that
8037 contains no dynamic components (that is, no components whose sizes
8038 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8039 true, gives an error message if the resulting type's size is over
8042 static struct type
*
8043 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8046 struct type
*index_type_desc
;
8047 struct type
*result
;
8049 if (ada_is_packed_array_type (type0
) /* revisit? */
8050 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
8053 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
8054 if (index_type_desc
== NULL
)
8056 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
8057 /* NOTE: elt_type---the fixed version of elt_type0---should never
8058 depend on the contents of the array in properly constructed
8060 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
8062 if (elt_type0
== elt_type
)
8065 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
8066 elt_type
, TYPE_INDEX_TYPE (type0
));
8071 struct type
*elt_type0
;
8074 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8075 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8077 /* NOTE: result---the fixed version of elt_type0---should never
8078 depend on the contents of the array in properly constructed
8080 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
8081 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8083 struct type
*range_type
=
8084 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
8085 dval
, TYPE_OBJFILE (type0
));
8086 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
8087 result
, range_type
);
8089 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8090 error ("array type with dynamic size is larger than varsize-limit");
8093 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
8098 /* A standard type (containing no dynamically sized components)
8099 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8100 DVAL describes a record containing any discriminants used in TYPE0,
8101 and may be NULL if there are none, or if the object of type TYPE at
8102 ADDRESS or in VALADDR contains these discriminants. */
8105 ada_to_fixed_type (struct type
*type
, char *valaddr
,
8106 CORE_ADDR address
, struct value
*dval
)
8108 CHECK_TYPEDEF (type
);
8109 switch (TYPE_CODE (type
))
8113 case TYPE_CODE_STRUCT
:
8115 struct type
*static_type
= to_static_fixed_type (type
);
8116 if (ada_is_tagged_type (static_type
, 0))
8118 struct type
*real_type
=
8119 type_from_tag (value_tag_from_contents_and_address (static_type
,
8122 if (real_type
!= NULL
)
8125 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
8127 case TYPE_CODE_ARRAY
:
8128 return to_fixed_array_type (type
, dval
, 1);
8129 case TYPE_CODE_UNION
:
8133 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8137 /* A standard (static-sized) type corresponding as well as possible to
8138 TYPE0, but based on no runtime data. */
8140 static struct type
*
8141 to_static_fixed_type (struct type
*type0
)
8148 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
8151 CHECK_TYPEDEF (type0
);
8153 switch (TYPE_CODE (type0
))
8157 case TYPE_CODE_STRUCT
:
8158 type
= dynamic_template_type (type0
);
8160 return template_to_static_fixed_type (type
);
8162 return template_to_static_fixed_type (type0
);
8163 case TYPE_CODE_UNION
:
8164 type
= ada_find_parallel_type (type0
, "___XVU");
8166 return template_to_static_fixed_type (type
);
8168 return template_to_static_fixed_type (type0
);
8172 /* A static approximation of TYPE with all type wrappers removed. */
8174 static struct type
*
8175 static_unwrap_type (struct type
*type
)
8177 if (ada_is_aligner_type (type
))
8179 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
8180 if (ada_type_name (type1
) == NULL
)
8181 TYPE_NAME (type1
) = ada_type_name (type
);
8183 return static_unwrap_type (type1
);
8187 struct type
*raw_real_type
= ada_get_base_type (type
);
8188 if (raw_real_type
== type
)
8191 return to_static_fixed_type (raw_real_type
);
8195 /* In some cases, incomplete and private types require
8196 cross-references that are not resolved as records (for example,
8198 type FooP is access Foo;
8200 type Foo is array ...;
8201 ). In these cases, since there is no mechanism for producing
8202 cross-references to such types, we instead substitute for FooP a
8203 stub enumeration type that is nowhere resolved, and whose tag is
8204 the name of the actual type. Call these types "non-record stubs". */
8206 /* A type equivalent to TYPE that is not a non-record stub, if one
8207 exists, otherwise TYPE. */
8210 ada_completed_type (struct type
*type
)
8212 CHECK_TYPEDEF (type
);
8213 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
8214 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
8215 || TYPE_TAG_NAME (type
) == NULL
)
8219 char *name
= TYPE_TAG_NAME (type
);
8220 struct type
*type1
= ada_find_any_type (name
);
8221 return (type1
== NULL
) ? type
: type1
;
8225 /* A value representing the data at VALADDR/ADDRESS as described by
8226 type TYPE0, but with a standard (static-sized) type that correctly
8227 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8228 type, then return VAL0 [this feature is simply to avoid redundant
8229 creation of struct values]. */
8231 static struct value
*
8232 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8235 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
8236 if (type
== type0
&& val0
!= NULL
)
8239 return value_from_contents_and_address (type
, 0, address
);
8242 /* A value representing VAL, but with a standard (static-sized) type
8243 that correctly describes it. Does not necessarily create a new
8246 static struct value
*
8247 ada_to_fixed_value (struct value
*val
)
8249 return ada_to_fixed_value_create (VALUE_TYPE (val
),
8250 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
8254 /* If the PC is pointing inside a function prologue, then re-adjust it
8255 past this prologue. */
8258 adjust_pc_past_prologue (CORE_ADDR
*pc
)
8260 struct symbol
*func_sym
= find_pc_function (*pc
);
8264 const struct symtab_and_line sal
=
8265 find_function_start_sal (func_sym
, 1);
8272 /* A value representing VAL, but with a standard (static-sized) type
8273 chosen to approximate the real type of VAL as well as possible, but
8274 without consulting any runtime values. For Ada dynamic-sized
8275 types, therefore, the type of the result is likely to be inaccurate. */
8278 ada_to_static_fixed_value (struct value
*val
)
8281 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
8282 if (type
== VALUE_TYPE (val
))
8285 return coerce_unspec_val_to_type (val
, type
);
8291 /* Table mapping attribute numbers to names.
8292 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8294 static const char *attribute_names
[] = {
8312 ada_attribute_name (enum exp_opcode n
)
8314 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8315 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8317 return attribute_names
[0];
8320 /* Evaluate the 'POS attribute applied to ARG. */
8323 pos_atr (struct value
*arg
)
8325 struct type
*type
= VALUE_TYPE (arg
);
8327 if (!discrete_type_p (type
))
8328 error ("'POS only defined on discrete types");
8330 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8333 LONGEST v
= value_as_long (arg
);
8335 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
8337 if (v
== TYPE_FIELD_BITPOS (type
, i
))
8340 error ("enumeration value is invalid: can't find 'POS");
8343 return value_as_long (arg
);
8346 static struct value
*
8347 value_pos_atr (struct value
*arg
)
8349 return value_from_longest (builtin_type_int
, pos_atr (arg
));
8352 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8354 static struct value
*
8355 value_val_atr (struct type
*type
, struct value
*arg
)
8357 if (!discrete_type_p (type
))
8358 error ("'VAL only defined on discrete types");
8359 if (!integer_type_p (VALUE_TYPE (arg
)))
8360 error ("'VAL requires integral argument");
8362 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8364 long pos
= value_as_long (arg
);
8365 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
8366 error ("argument to 'VAL out of range");
8367 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
8370 return value_from_longest (type
, value_as_long (arg
));
8376 /* True if TYPE appears to be an Ada character type.
8377 [At the moment, this is true only for Character and Wide_Character;
8378 It is a heuristic test that could stand improvement]. */
8381 ada_is_character_type (struct type
*type
)
8383 const char *name
= ada_type_name (type
);
8386 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
8387 || TYPE_CODE (type
) == TYPE_CODE_INT
8388 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8389 && (strcmp (name
, "character") == 0
8390 || strcmp (name
, "wide_character") == 0
8391 || strcmp (name
, "unsigned char") == 0);
8394 /* True if TYPE appears to be an Ada string type. */
8397 ada_is_string_type (struct type
*type
)
8399 CHECK_TYPEDEF (type
);
8401 && TYPE_CODE (type
) != TYPE_CODE_PTR
8402 && (ada_is_simple_array_type (type
)
8403 || ada_is_array_descriptor_type (type
))
8404 && ada_array_arity (type
) == 1)
8406 struct type
*elttype
= ada_array_element_type (type
, 1);
8408 return ada_is_character_type (elttype
);
8415 /* True if TYPE is a struct type introduced by the compiler to force the
8416 alignment of a value. Such types have a single field with a
8417 distinctive name. */
8420 ada_is_aligner_type (struct type
*type
)
8422 CHECK_TYPEDEF (type
);
8423 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
8424 && TYPE_NFIELDS (type
) == 1
8425 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
8428 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8429 the parallel type. */
8432 ada_get_base_type (struct type
*raw_type
)
8434 struct type
*real_type_namer
;
8435 struct type
*raw_real_type
;
8437 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
8440 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
8441 if (real_type_namer
== NULL
8442 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
8443 || TYPE_NFIELDS (real_type_namer
) != 1)
8446 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
8447 if (raw_real_type
== NULL
)
8450 return raw_real_type
;
8453 /* The type of value designated by TYPE, with all aligners removed. */
8456 ada_aligned_type (struct type
*type
)
8458 if (ada_is_aligner_type (type
))
8459 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
8461 return ada_get_base_type (type
);
8465 /* The address of the aligned value in an object at address VALADDR
8466 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
8469 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
8471 if (ada_is_aligner_type (type
))
8472 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
8474 TYPE_FIELD_BITPOS (type
,
8475 0) / TARGET_CHAR_BIT
);
8482 /* The printed representation of an enumeration literal with encoded
8483 name NAME. The value is good to the next call of ada_enum_name. */
8485 ada_enum_name (const char *name
)
8487 static char *result
;
8488 static size_t result_len
= 0;
8491 /* First, unqualify the enumeration name:
8492 1. Search for the last '.' character. If we find one, then skip
8493 all the preceeding characters, the unqualified name starts
8494 right after that dot.
8495 2. Otherwise, we may be debugging on a target where the compiler
8496 translates dots into "__". Search forward for double underscores,
8497 but stop searching when we hit an overloading suffix, which is
8498 of the form "__" followed by digits. */
8500 tmp
= strrchr (name
, '.');
8505 while ((tmp
= strstr (name
, "__")) != NULL
)
8507 if (isdigit (tmp
[2]))
8517 if (name
[1] == 'U' || name
[1] == 'W')
8519 if (sscanf (name
+ 2, "%x", &v
) != 1)
8525 GROW_VECT (result
, result_len
, 16);
8526 if (isascii (v
) && isprint (v
))
8527 sprintf (result
, "'%c'", v
);
8528 else if (name
[1] == 'U')
8529 sprintf (result
, "[\"%02x\"]", v
);
8531 sprintf (result
, "[\"%04x\"]", v
);
8537 tmp
= strstr (name
, "__");
8539 tmp
= strstr (name
, "$");
8542 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
8543 strncpy (result
, name
, tmp
- name
);
8544 result
[tmp
- name
] = '\0';
8552 static struct value
*
8553 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
8556 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
8557 (expect_type
, exp
, pos
, noside
);
8560 /* Evaluate the subexpression of EXP starting at *POS as for
8561 evaluate_type, updating *POS to point just past the evaluated
8564 static struct value
*
8565 evaluate_subexp_type (struct expression
*exp
, int *pos
)
8567 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
8568 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8571 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8574 static struct value
*
8575 unwrap_value (struct value
*val
)
8577 struct type
*type
= check_typedef (VALUE_TYPE (val
));
8578 if (ada_is_aligner_type (type
))
8580 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
8581 NULL
, "internal structure");
8582 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
8583 if (ada_type_name (val_type
) == NULL
)
8584 TYPE_NAME (val_type
) = ada_type_name (type
);
8586 return unwrap_value (v
);
8590 struct type
*raw_real_type
=
8591 ada_completed_type (ada_get_base_type (type
));
8593 if (type
== raw_real_type
)
8597 coerce_unspec_val_to_type
8598 (val
, ada_to_fixed_type (raw_real_type
, 0,
8599 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
8604 static struct value
*
8605 cast_to_fixed (struct type
*type
, struct value
*arg
)
8609 if (type
== VALUE_TYPE (arg
))
8611 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
8612 val
= ada_float_to_fixed (type
,
8613 ada_fixed_to_float (VALUE_TYPE (arg
),
8614 value_as_long (arg
)));
8618 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
8619 val
= ada_float_to_fixed (type
, argd
);
8622 return value_from_longest (type
, val
);
8625 static struct value
*
8626 cast_from_fixed_to_double (struct value
*arg
)
8628 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
8629 value_as_long (arg
));
8630 return value_from_double (builtin_type_double
, val
);
8633 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8634 return the converted value. */
8636 static struct value
*
8637 coerce_for_assign (struct type
*type
, struct value
*val
)
8639 struct type
*type2
= VALUE_TYPE (val
);
8643 CHECK_TYPEDEF (type2
);
8644 CHECK_TYPEDEF (type
);
8646 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
8647 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8649 val
= ada_value_ind (val
);
8650 type2
= VALUE_TYPE (val
);
8653 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
8654 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8656 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
8657 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
8658 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
8659 error ("Incompatible types in assignment");
8660 VALUE_TYPE (val
) = type
;
8665 static struct value
*
8666 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
8669 struct type
*type1
, *type2
;
8674 type1
= base_type (check_typedef (VALUE_TYPE (arg1
)));
8675 type2
= base_type (check_typedef (VALUE_TYPE (arg2
)));
8677 if (TYPE_CODE (type1
) != TYPE_CODE_INT
8678 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
8679 return value_binop (arg1
, arg2
, op
);
8688 return value_binop (arg1
, arg2
, op
);
8691 v2
= value_as_long (arg2
);
8693 error ("second operand of %s must not be zero.", op_string (op
));
8695 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
8696 return value_binop (arg1
, arg2
, op
);
8698 v1
= value_as_long (arg1
);
8703 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
8704 v
+= v
> 0 ? -1 : 1;
8712 /* Should not reach this point. */
8716 val
= allocate_value (type1
);
8717 store_unsigned_integer (VALUE_CONTENTS_RAW (val
),
8718 TYPE_LENGTH (VALUE_TYPE (val
)), v
);
8723 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
8725 if (ada_is_direct_array_type (VALUE_TYPE (arg1
))
8726 || ada_is_direct_array_type (VALUE_TYPE (arg2
)))
8728 arg1
= ada_coerce_to_simple_array (arg1
);
8729 arg2
= ada_coerce_to_simple_array (arg2
);
8730 if (TYPE_CODE (VALUE_TYPE (arg1
)) != TYPE_CODE_ARRAY
8731 || TYPE_CODE (VALUE_TYPE (arg2
)) != TYPE_CODE_ARRAY
)
8732 error ("Attempt to compare array with non-array");
8733 /* FIXME: The following works only for types whose
8734 representations use all bits (no padding or undefined bits)
8735 and do not have user-defined equality. */
8737 TYPE_LENGTH (VALUE_TYPE (arg1
)) == TYPE_LENGTH (VALUE_TYPE (arg2
))
8738 && memcmp (VALUE_CONTENTS (arg1
), VALUE_CONTENTS (arg2
),
8739 TYPE_LENGTH (VALUE_TYPE (arg1
))) == 0;
8741 return value_equal (arg1
, arg2
);
8745 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8746 int *pos
, enum noside noside
)
8749 int tem
, tem2
, tem3
;
8751 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8754 struct value
**argvec
;
8758 op
= exp
->elts
[pc
].opcode
;
8765 unwrap_value (evaluate_subexp_standard
8766 (expect_type
, exp
, pos
, noside
));
8770 struct value
*result
;
8772 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8773 /* The result type will have code OP_STRING, bashed there from
8774 OP_ARRAY. Bash it back. */
8775 if (TYPE_CODE (VALUE_TYPE (result
)) == TYPE_CODE_STRING
)
8776 TYPE_CODE (VALUE_TYPE (result
)) = TYPE_CODE_ARRAY
;
8782 type
= exp
->elts
[pc
+ 1].type
;
8783 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8784 if (noside
== EVAL_SKIP
)
8786 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
8788 if (ada_is_fixed_point_type (type
))
8789 arg1
= cast_to_fixed (type
, arg1
);
8790 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8791 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
8792 else if (VALUE_LVAL (arg1
) == lval_memory
)
8794 /* This is in case of the really obscure (and undocumented,
8795 but apparently expected) case of (Foo) Bar.all, where Bar
8796 is an integer constant and Foo is a dynamic-sized type.
8797 If we don't do this, ARG1 will simply be relabeled with
8799 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8800 return value_zero (to_static_fixed_type (type
), not_lval
);
8802 ada_to_fixed_value_create
8803 (type
, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
8806 arg1
= value_cast (type
, arg1
);
8812 type
= exp
->elts
[pc
+ 1].type
;
8813 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8816 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8817 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
8818 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8820 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8821 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
8822 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8824 ("Fixed-point values must be assigned to fixed-point variables");
8826 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
8827 return ada_value_assign (arg1
, arg2
);
8830 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8831 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8832 if (noside
== EVAL_SKIP
)
8834 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
8835 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8836 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
8837 error ("Operands of fixed-point addition must have the same type");
8838 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
8841 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8842 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8843 if (noside
== EVAL_SKIP
)
8845 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
8846 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8847 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
8848 error ("Operands of fixed-point subtraction must have the same type");
8849 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
8853 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8854 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8855 if (noside
== EVAL_SKIP
)
8857 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8858 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8859 return value_zero (VALUE_TYPE (arg1
), not_lval
);
8862 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8863 arg1
= cast_from_fixed_to_double (arg1
);
8864 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8865 arg2
= cast_from_fixed_to_double (arg2
);
8866 return ada_value_binop (arg1
, arg2
, op
);
8871 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8872 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8873 if (noside
== EVAL_SKIP
)
8875 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8876 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8877 return value_zero (VALUE_TYPE (arg1
), not_lval
);
8879 return ada_value_binop (arg1
, arg2
, op
);
8882 case BINOP_NOTEQUAL
:
8883 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8884 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
8885 if (noside
== EVAL_SKIP
)
8887 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8890 tem
= ada_value_equal (arg1
, arg2
);
8891 if (op
== BINOP_NOTEQUAL
)
8893 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
8896 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8897 if (noside
== EVAL_SKIP
)
8899 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8900 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
8902 return value_neg (arg1
);
8906 if (noside
== EVAL_SKIP
)
8911 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8912 /* Only encountered when an unresolved symbol occurs in a
8913 context other than a function call, in which case, it is
8915 error ("Unexpected unresolved symbol, %s, during evaluation",
8916 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8917 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8921 (to_static_fixed_type
8922 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8928 unwrap_value (evaluate_subexp_standard
8929 (expect_type
, exp
, pos
, noside
));
8930 return ada_to_fixed_value (arg1
);
8936 /* Allocate arg vector, including space for the function to be
8937 called in argvec[0] and a terminating NULL. */
8938 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8940 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8942 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8943 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8944 error ("Unexpected unresolved symbol, %s, during evaluation",
8945 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8948 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8949 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8952 if (noside
== EVAL_SKIP
)
8956 if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec
[0]))))
8957 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8958 else if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
8959 || (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_ARRAY
8960 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8961 argvec
[0] = value_addr (argvec
[0]);
8963 type
= check_typedef (VALUE_TYPE (argvec
[0]));
8964 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8966 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
8968 case TYPE_CODE_FUNC
:
8969 type
= check_typedef (TYPE_TARGET_TYPE (type
));
8971 case TYPE_CODE_ARRAY
:
8973 case TYPE_CODE_STRUCT
:
8974 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8975 argvec
[0] = ada_value_ind (argvec
[0]);
8976 type
= check_typedef (TYPE_TARGET_TYPE (type
));
8979 error ("cannot subscript or call something of type `%s'",
8980 ada_type_name (VALUE_TYPE (argvec
[0])));
8985 switch (TYPE_CODE (type
))
8987 case TYPE_CODE_FUNC
:
8988 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8989 return allocate_value (TYPE_TARGET_TYPE (type
));
8990 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8991 case TYPE_CODE_STRUCT
:
8995 arity
= ada_array_arity (type
);
8996 type
= ada_array_element_type (type
, nargs
);
8998 error ("cannot subscript or call a record");
9000 error ("wrong number of subscripts; expecting %d", arity
);
9001 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9002 return allocate_value (ada_aligned_type (type
));
9004 unwrap_value (ada_value_subscript
9005 (argvec
[0], nargs
, argvec
+ 1));
9007 case TYPE_CODE_ARRAY
:
9008 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9010 type
= ada_array_element_type (type
, nargs
);
9012 error ("element type of array unknown");
9014 return allocate_value (ada_aligned_type (type
));
9017 unwrap_value (ada_value_subscript
9018 (ada_coerce_to_simple_array (argvec
[0]),
9019 nargs
, argvec
+ 1));
9020 case TYPE_CODE_PTR
: /* Pointer to array */
9021 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
9022 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9024 type
= ada_array_element_type (type
, nargs
);
9026 error ("element type of array unknown");
9028 return allocate_value (ada_aligned_type (type
));
9031 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
9032 nargs
, argvec
+ 1));
9035 error ("Internal error in evaluate_subexp");
9040 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9041 struct value
*low_bound_val
=
9042 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9043 LONGEST low_bound
= pos_atr (low_bound_val
);
9045 = pos_atr (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
9046 if (noside
== EVAL_SKIP
)
9049 /* If this is a reference to an aligner type, then remove all
9051 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
9052 && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
))))
9053 TYPE_TARGET_TYPE (VALUE_TYPE (array
)) =
9054 ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)));
9056 if (ada_is_packed_array_type (VALUE_TYPE (array
)))
9057 error ("cannot slice a packed array");
9059 /* If this is a reference to an array or an array lvalue,
9060 convert to a pointer. */
9061 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
9062 || (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_ARRAY
9063 && VALUE_LVAL (array
) == lval_memory
))
9064 array
= value_addr (array
);
9066 if (noside
== EVAL_AVOID_SIDE_EFFECTS
9067 && ada_is_array_descriptor_type (check_typedef
9068 (VALUE_TYPE (array
))))
9069 return empty_array (ada_type_of_array (array
, 0), low_bound
);
9071 array
= ada_coerce_to_simple_array_ptr (array
);
9073 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
)
9075 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9076 return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
9080 struct type
*arr_type0
=
9081 to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
9083 return ada_value_slice_ptr (array
, arr_type0
,
9088 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9090 else if (high_bound
< low_bound
)
9091 return empty_array (VALUE_TYPE (array
), low_bound
);
9093 return ada_value_slice (array
, (int) low_bound
, (int) high_bound
);
9098 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9099 type
= exp
->elts
[pc
+ 1].type
;
9101 if (noside
== EVAL_SKIP
)
9104 switch (TYPE_CODE (type
))
9107 lim_warning ("Membership test incompletely implemented; "
9108 "always returns true", 0);
9109 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
9111 case TYPE_CODE_RANGE
:
9112 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
9113 arg3
= value_from_longest (builtin_type_int
,
9114 TYPE_HIGH_BOUND (type
));
9116 value_from_longest (builtin_type_int
,
9117 (value_less (arg1
, arg3
)
9118 || value_equal (arg1
, arg3
))
9119 && (value_less (arg2
, arg1
)
9120 || value_equal (arg2
, arg1
)));
9123 case BINOP_IN_BOUNDS
:
9125 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9126 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9128 if (noside
== EVAL_SKIP
)
9131 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9132 return value_zero (builtin_type_int
, not_lval
);
9134 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9136 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg2
)))
9137 error ("invalid dimension number to '%s", "range");
9139 arg3
= ada_array_bound (arg2
, tem
, 1);
9140 arg2
= ada_array_bound (arg2
, tem
, 0);
9143 value_from_longest (builtin_type_int
,
9144 (value_less (arg1
, arg3
)
9145 || value_equal (arg1
, arg3
))
9146 && (value_less (arg2
, arg1
)
9147 || value_equal (arg2
, arg1
)));
9149 case TERNOP_IN_RANGE
:
9150 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9151 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9152 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9154 if (noside
== EVAL_SKIP
)
9158 value_from_longest (builtin_type_int
,
9159 (value_less (arg1
, arg3
)
9160 || value_equal (arg1
, arg3
))
9161 && (value_less (arg2
, arg1
)
9162 || value_equal (arg2
, arg1
)));
9168 struct type
*type_arg
;
9169 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9171 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9173 type_arg
= exp
->elts
[pc
+ 2].type
;
9177 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9181 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
9182 error ("illegal operand to '%s", ada_attribute_name (op
));
9183 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
9186 if (noside
== EVAL_SKIP
)
9189 if (type_arg
== NULL
)
9191 arg1
= ada_coerce_ref (arg1
);
9193 if (ada_is_packed_array_type (VALUE_TYPE (arg1
)))
9194 arg1
= ada_coerce_to_simple_array (arg1
);
9196 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg1
)))
9197 error ("invalid dimension number to '%s",
9198 ada_attribute_name (op
));
9200 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9202 type
= ada_index_type (VALUE_TYPE (arg1
), tem
);
9205 ("attempt to take bound of something that is not an array");
9206 return allocate_value (type
);
9211 default: /* Should never happen. */
9212 error ("unexpected attribute encountered");
9214 return ada_array_bound (arg1
, tem
, 0);
9216 return ada_array_bound (arg1
, tem
, 1);
9218 return ada_array_length (arg1
, tem
);
9221 else if (discrete_type_p (type_arg
))
9223 struct type
*range_type
;
9224 char *name
= ada_type_name (type_arg
);
9226 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
9228 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
9229 if (range_type
== NULL
)
9230 range_type
= type_arg
;
9234 error ("unexpected attribute encountered");
9236 return discrete_type_low_bound (range_type
);
9238 return discrete_type_high_bound (range_type
);
9240 error ("the 'length attribute applies only to array types");
9243 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
9244 error ("unimplemented type attribute");
9249 if (ada_is_packed_array_type (type_arg
))
9250 type_arg
= decode_packed_array_type (type_arg
);
9252 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
9253 error ("invalid dimension number to '%s",
9254 ada_attribute_name (op
));
9256 type
= ada_index_type (type_arg
, tem
);
9259 ("attempt to take bound of something that is not an array");
9260 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9261 return allocate_value (type
);
9266 error ("unexpected attribute encountered");
9268 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9269 return value_from_longest (type
, low
);
9271 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
9272 return value_from_longest (type
, high
);
9274 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9275 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
9276 return value_from_longest (type
, high
- low
+ 1);
9282 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9283 if (noside
== EVAL_SKIP
)
9286 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9287 return value_zero (ada_tag_type (arg1
), not_lval
);
9289 return ada_value_tag (arg1
);
9293 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9294 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9295 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9296 if (noside
== EVAL_SKIP
)
9298 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9299 return value_zero (VALUE_TYPE (arg1
), not_lval
);
9301 return value_binop (arg1
, arg2
,
9302 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9304 case OP_ATR_MODULUS
:
9306 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
9307 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9309 if (noside
== EVAL_SKIP
)
9312 if (!ada_is_modular_type (type_arg
))
9313 error ("'modulus must be applied to modular type");
9315 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9316 ada_modulus (type_arg
));
9321 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9322 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9323 if (noside
== EVAL_SKIP
)
9325 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9326 return value_zero (builtin_type_int
, not_lval
);
9328 return value_pos_atr (arg1
);
9331 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9332 if (noside
== EVAL_SKIP
)
9334 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9335 return value_zero (builtin_type_int
, not_lval
);
9337 return value_from_longest (builtin_type_int
,
9339 * TYPE_LENGTH (VALUE_TYPE (arg1
)));
9342 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9343 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9344 type
= exp
->elts
[pc
+ 2].type
;
9345 if (noside
== EVAL_SKIP
)
9347 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9348 return value_zero (type
, not_lval
);
9350 return value_val_atr (type
, arg1
);
9353 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9354 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9355 if (noside
== EVAL_SKIP
)
9357 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9358 return value_zero (VALUE_TYPE (arg1
), not_lval
);
9360 return value_binop (arg1
, arg2
, op
);
9363 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9364 if (noside
== EVAL_SKIP
)
9370 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9371 if (noside
== EVAL_SKIP
)
9373 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
9374 return value_neg (arg1
);
9379 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
9380 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
9381 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
9382 if (noside
== EVAL_SKIP
)
9384 type
= check_typedef (VALUE_TYPE (arg1
));
9385 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9387 if (ada_is_array_descriptor_type (type
))
9388 /* GDB allows dereferencing GNAT array descriptors. */
9390 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9391 if (arrType
== NULL
)
9392 error ("Attempt to dereference null array pointer.");
9393 return value_at_lazy (arrType
, 0, NULL
);
9395 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9396 || TYPE_CODE (type
) == TYPE_CODE_REF
9397 /* In C you can dereference an array to get the 1st elt. */
9398 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9401 (to_static_fixed_type
9402 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
9404 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9405 /* GDB allows dereferencing an int. */
9406 return value_zero (builtin_type_int
, lval_memory
);
9408 error ("Attempt to take contents of a non-pointer value.");
9410 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9411 type
= check_typedef (VALUE_TYPE (arg1
));
9413 if (ada_is_array_descriptor_type (type
))
9414 /* GDB allows dereferencing GNAT array descriptors. */
9415 return ada_coerce_to_simple_array (arg1
);
9417 return ada_value_ind (arg1
);
9419 case STRUCTOP_STRUCT
:
9420 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9421 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9422 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9423 if (noside
== EVAL_SKIP
)
9425 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9427 struct type
*type1
= VALUE_TYPE (arg1
);
9428 if (ada_is_tagged_type (type1
, 1))
9430 type
= ada_lookup_struct_elt_type (type1
,
9431 &exp
->elts
[pc
+ 2].string
,
9434 /* In this case, we assume that the field COULD exist
9435 in some extension of the type. Return an object of
9436 "type" void, which will match any formal
9437 (see ada_type_match). */
9438 return value_zero (builtin_type_void
, lval_memory
);
9442 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9445 return value_zero (ada_aligned_type (type
), lval_memory
);
9449 ada_to_fixed_value (unwrap_value
9450 (ada_value_struct_elt
9451 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
9453 /* The value is not supposed to be used. This is here to make it
9454 easier to accommodate expressions that contain types. */
9456 if (noside
== EVAL_SKIP
)
9458 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9459 return allocate_value (builtin_type_void
);
9461 error ("Attempt to use a type name as an expression");
9465 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
9471 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9472 type name that encodes the 'small and 'delta information.
9473 Otherwise, return NULL. */
9476 fixed_type_info (struct type
*type
)
9478 const char *name
= ada_type_name (type
);
9479 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9481 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9483 const char *tail
= strstr (name
, "___XF_");
9489 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9490 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9495 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9498 ada_is_fixed_point_type (struct type
*type
)
9500 return fixed_type_info (type
) != NULL
;
9503 /* Return non-zero iff TYPE represents a System.Address type. */
9506 ada_is_system_address_type (struct type
*type
)
9508 return (TYPE_NAME (type
)
9509 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9512 /* Assuming that TYPE is the representation of an Ada fixed-point
9513 type, return its delta, or -1 if the type is malformed and the
9514 delta cannot be determined. */
9517 ada_delta (struct type
*type
)
9519 const char *encoding
= fixed_type_info (type
);
9522 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
9525 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
9528 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9529 factor ('SMALL value) associated with the type. */
9532 scaling_factor (struct type
*type
)
9534 const char *encoding
= fixed_type_info (type
);
9535 unsigned long num0
, den0
, num1
, den1
;
9538 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
9543 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
9545 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
9549 /* Assuming that X is the representation of a value of fixed-point
9550 type TYPE, return its floating-point equivalent. */
9553 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9555 return (DOUBLEST
) x
*scaling_factor (type
);
9558 /* The representation of a fixed-point value of type TYPE
9559 corresponding to the value X. */
9562 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9564 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9568 /* VAX floating formats */
9570 /* Non-zero iff TYPE represents one of the special VAX floating-point
9574 ada_is_vax_floating_type (struct type
*type
)
9577 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
9580 && (TYPE_CODE (type
) == TYPE_CODE_INT
9581 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9582 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
9585 /* The type of special VAX floating-point type this is, assuming
9586 ada_is_vax_floating_point. */
9589 ada_vax_float_type_suffix (struct type
*type
)
9591 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
9594 /* A value representing the special debugging function that outputs
9595 VAX floating-point values of the type represented by TYPE. Assumes
9596 ada_is_vax_floating_type (TYPE). */
9599 ada_vax_float_print_function (struct type
*type
)
9601 switch (ada_vax_float_type_suffix (type
))
9604 return get_var_value ("DEBUG_STRING_F", 0);
9606 return get_var_value ("DEBUG_STRING_D", 0);
9608 return get_var_value ("DEBUG_STRING_G", 0);
9610 error ("invalid VAX floating-point type");
9617 /* Scan STR beginning at position K for a discriminant name, and
9618 return the value of that discriminant field of DVAL in *PX. If
9619 PNEW_K is not null, put the position of the character beyond the
9620 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9621 not alter *PX and *PNEW_K if unsuccessful. */
9624 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9627 static char *bound_buffer
= NULL
;
9628 static size_t bound_buffer_len
= 0;
9631 struct value
*bound_val
;
9633 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9636 pend
= strstr (str
+ k
, "__");
9640 k
+= strlen (bound
);
9644 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9645 bound
= bound_buffer
;
9646 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9647 bound
[pend
- (str
+ k
)] = '\0';
9651 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
9652 if (bound_val
== NULL
)
9655 *px
= value_as_long (bound_val
);
9661 /* Value of variable named NAME in the current environment. If
9662 no such variable found, then if ERR_MSG is null, returns 0, and
9663 otherwise causes an error with message ERR_MSG. */
9665 static struct value
*
9666 get_var_value (char *name
, char *err_msg
)
9668 struct ada_symbol_info
*syms
;
9671 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9676 if (err_msg
== NULL
)
9679 error ("%s", err_msg
);
9682 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9685 /* Value of integer variable named NAME in the current environment. If
9686 no such variable found, returns 0, and sets *FLAG to 0. If
9687 successful, sets *FLAG to 1. */
9690 get_int_var_value (char *name
, int *flag
)
9692 struct value
*var_val
= get_var_value (name
, 0);
9704 return value_as_long (var_val
);
9709 /* Return a range type whose base type is that of the range type named
9710 NAME in the current environment, and whose bounds are calculated
9711 from NAME according to the GNAT range encoding conventions.
9712 Extract discriminant values, if needed, from DVAL. If a new type
9713 must be created, allocate in OBJFILE's space. The bounds
9714 information, in general, is encoded in NAME, the base type given in
9715 the named range type. */
9717 static struct type
*
9718 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9720 struct type
*raw_type
= ada_find_any_type (name
);
9721 struct type
*base_type
;
9724 if (raw_type
== NULL
)
9725 base_type
= builtin_type_int
;
9726 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9727 base_type
= TYPE_TARGET_TYPE (raw_type
);
9729 base_type
= raw_type
;
9731 subtype_info
= strstr (name
, "___XD");
9732 if (subtype_info
== NULL
)
9736 static char *name_buf
= NULL
;
9737 static size_t name_len
= 0;
9738 int prefix_len
= subtype_info
- name
;
9744 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9745 strncpy (name_buf
, name
, prefix_len
);
9746 name_buf
[prefix_len
] = '\0';
9749 bounds_str
= strchr (subtype_info
, '_');
9752 if (*subtype_info
== 'L')
9754 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9755 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9757 if (bounds_str
[n
] == '_')
9759 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9766 strcpy (name_buf
+ prefix_len
, "___L");
9767 L
= get_int_var_value (name_buf
, &ok
);
9770 lim_warning ("Unknown lower bound, using 1.", 1);
9775 if (*subtype_info
== 'U')
9777 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9778 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9784 strcpy (name_buf
+ prefix_len
, "___U");
9785 U
= get_int_var_value (name_buf
, &ok
);
9788 lim_warning ("Unknown upper bound, using %ld.", (long) L
);
9793 if (objfile
== NULL
)
9794 objfile
= TYPE_OBJFILE (base_type
);
9795 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9796 TYPE_NAME (type
) = name
;
9801 /* True iff NAME is the name of a range type. */
9804 ada_is_range_type_name (const char *name
)
9806 return (name
!= NULL
&& strstr (name
, "___XD"));
9812 /* True iff TYPE is an Ada modular type. */
9815 ada_is_modular_type (struct type
*type
)
9817 struct type
*subranged_type
= base_type (type
);
9819 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9820 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
9821 && TYPE_UNSIGNED (subranged_type
));
9824 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9827 ada_modulus (struct type
* type
)
9829 return TYPE_HIGH_BOUND (type
) + 1;
9833 /* Information about operators given special treatment in functions
9835 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
9837 #define ADA_OPERATORS \
9838 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
9839 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
9840 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
9841 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
9842 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
9843 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
9844 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
9845 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
9846 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
9847 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
9848 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
9849 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
9850 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
9851 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
9852 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
9853 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
9856 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
9858 switch (exp
->elts
[pc
- 1].opcode
)
9861 operator_length_standard (exp
, pc
, oplenp
, argsp
);
9864 #define OP_DEFN(op, len, args, binop) \
9865 case op: *oplenp = len; *argsp = args; break;
9872 ada_op_name (enum exp_opcode opcode
)
9877 return op_name_standard (opcode
);
9878 #define OP_DEFN(op, len, args, binop) case op: return #op;
9884 /* As for operator_length, but assumes PC is pointing at the first
9885 element of the operator, and gives meaningful results only for the
9886 Ada-specific operators. */
9889 ada_forward_operator_length (struct expression
*exp
, int pc
,
9890 int *oplenp
, int *argsp
)
9892 switch (exp
->elts
[pc
].opcode
)
9895 *oplenp
= *argsp
= 0;
9897 #define OP_DEFN(op, len, args, binop) \
9898 case op: *oplenp = len; *argsp = args; break;
9905 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
9907 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
9912 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
9916 /* Ada attributes ('Foo). */
9923 case OP_ATR_MODULUS
:
9932 fprintf_filtered (stream
, "Type @");
9933 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
9934 fprintf_filtered (stream
, " (");
9935 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
9936 fprintf_filtered (stream
, ")");
9938 case BINOP_IN_BOUNDS
:
9939 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
9941 case TERNOP_IN_RANGE
:
9945 return dump_subexp_body_standard (exp
, stream
, elt
);
9949 for (i
= 0; i
< nargs
; i
+= 1)
9950 elt
= dump_subexp (exp
, stream
, elt
);
9955 /* The Ada extension of print_subexp (q.v.). */
9958 ada_print_subexp (struct expression
*exp
, int *pos
,
9959 struct ui_file
*stream
, enum precedence prec
)
9963 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
9965 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9970 print_subexp_standard (exp
, pos
, stream
, prec
);
9975 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
9978 case BINOP_IN_BOUNDS
:
9980 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9981 fputs_filtered (" in ", stream
);
9982 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9983 fputs_filtered ("'range", stream
);
9984 if (exp
->elts
[pc
+ 1].longconst
> 1)
9985 fprintf_filtered (stream
, "(%ld)",
9986 (long) exp
->elts
[pc
+ 1].longconst
);
9989 case TERNOP_IN_RANGE
:
9991 if (prec
>= PREC_EQUAL
)
9992 fputs_filtered ("(", stream
);
9993 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9994 fputs_filtered (" in ", stream
);
9995 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
9996 fputs_filtered (" .. ", stream
);
9997 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
9998 if (prec
>= PREC_EQUAL
)
9999 fputs_filtered (")", stream
);
10004 case OP_ATR_LENGTH
:
10008 case OP_ATR_MODULUS
:
10014 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
10016 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
10017 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
10021 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10022 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
10026 for (tem
= 1; tem
< nargs
; tem
+= 1)
10028 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
10029 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
10031 fputs_filtered (")", stream
);
10037 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
10038 fputs_filtered ("'(", stream
);
10039 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10040 fputs_filtered (")", stream
);
10043 case UNOP_IN_RANGE
:
10045 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10046 fputs_filtered (" in ", stream
);
10047 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10052 /* Table mapping opcodes into strings for printing operators
10053 and precedences of the operators. */
10055 static const struct op_print ada_op_print_tab
[] = {
10056 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10057 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10058 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10059 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10060 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10061 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10062 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10063 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10064 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10065 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10066 {">", BINOP_GTR
, PREC_ORDER
, 0},
10067 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10068 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10069 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10070 {"+", BINOP_ADD
, PREC_ADD
, 0},
10071 {"-", BINOP_SUB
, PREC_ADD
, 0},
10072 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10073 {"*", BINOP_MUL
, PREC_MUL
, 0},
10074 {"/", BINOP_DIV
, PREC_MUL
, 0},
10075 {"rem", BINOP_REM
, PREC_MUL
, 0},
10076 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10077 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10078 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10079 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10080 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10081 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10082 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10083 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10084 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10085 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10086 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10090 /* Fundamental Ada Types */
10092 /* Create a fundamental Ada type using default reasonable for the current
10095 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
10096 define fundamental types such as "int" or "double". Others (stabs or
10097 DWARF version 2, etc) do define fundamental types. For the formats which
10098 don't provide fundamental types, gdb can create such types using this
10101 FIXME: Some compilers distinguish explicitly signed integral types
10102 (signed short, signed int, signed long) from "regular" integral types
10103 (short, int, long) in the debugging information. There is some dis-
10104 agreement as to how useful this feature is. In particular, gcc does
10105 not support this. Also, only some debugging formats allow the
10106 distinction to be passed on to a debugger. For now, we always just
10107 use "short", "int", or "long" as the type name, for both the implicit
10108 and explicitly signed types. This also makes life easier for the
10109 gdb test suite since we don't have to account for the differences
10110 in output depending upon what the compiler and debugging format
10111 support. We will probably have to re-examine the issue when gdb
10112 starts taking it's fundamental type information directly from the
10113 debugging information supplied by the compiler. fnf@cygnus.com */
10115 static struct type
*
10116 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
10118 struct type
*type
= NULL
;
10123 /* FIXME: For now, if we are asked to produce a type not in this
10124 language, create the equivalent of a C integer type with the
10125 name "<?type?>". When all the dust settles from the type
10126 reconstruction work, this should probably become an error. */
10127 type
= init_type (TYPE_CODE_INT
,
10128 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10129 0, "<?type?>", objfile
);
10130 warning ("internal error: no Ada fundamental type %d", typeid);
10133 type
= init_type (TYPE_CODE_VOID
,
10134 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10135 0, "void", objfile
);
10138 type
= init_type (TYPE_CODE_INT
,
10139 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10140 0, "character", objfile
);
10142 case FT_SIGNED_CHAR
:
10143 type
= init_type (TYPE_CODE_INT
,
10144 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10145 0, "signed char", objfile
);
10147 case FT_UNSIGNED_CHAR
:
10148 type
= init_type (TYPE_CODE_INT
,
10149 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10150 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
10153 type
= init_type (TYPE_CODE_INT
,
10154 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10155 0, "short_integer", objfile
);
10157 case FT_SIGNED_SHORT
:
10158 type
= init_type (TYPE_CODE_INT
,
10159 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10160 0, "short_integer", objfile
);
10162 case FT_UNSIGNED_SHORT
:
10163 type
= init_type (TYPE_CODE_INT
,
10164 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10165 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
10168 type
= init_type (TYPE_CODE_INT
,
10169 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10170 0, "integer", objfile
);
10172 case FT_SIGNED_INTEGER
:
10173 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/
10175 0, "integer", objfile
); /* FIXME -fnf */
10177 case FT_UNSIGNED_INTEGER
:
10178 type
= init_type (TYPE_CODE_INT
,
10179 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10180 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
10183 type
= init_type (TYPE_CODE_INT
,
10184 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10185 0, "long_integer", objfile
);
10187 case FT_SIGNED_LONG
:
10188 type
= init_type (TYPE_CODE_INT
,
10189 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10190 0, "long_integer", objfile
);
10192 case FT_UNSIGNED_LONG
:
10193 type
= init_type (TYPE_CODE_INT
,
10194 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10195 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
10198 type
= init_type (TYPE_CODE_INT
,
10199 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10200 0, "long_long_integer", objfile
);
10202 case FT_SIGNED_LONG_LONG
:
10203 type
= init_type (TYPE_CODE_INT
,
10204 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10205 0, "long_long_integer", objfile
);
10207 case FT_UNSIGNED_LONG_LONG
:
10208 type
= init_type (TYPE_CODE_INT
,
10209 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10210 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
10213 type
= init_type (TYPE_CODE_FLT
,
10214 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
10215 0, "float", objfile
);
10217 case FT_DBL_PREC_FLOAT
:
10218 type
= init_type (TYPE_CODE_FLT
,
10219 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10220 0, "long_float", objfile
);
10222 case FT_EXT_PREC_FLOAT
:
10223 type
= init_type (TYPE_CODE_FLT
,
10224 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10225 0, "long_long_float", objfile
);
10231 enum ada_primitive_types
{
10232 ada_primitive_type_int
,
10233 ada_primitive_type_long
,
10234 ada_primitive_type_short
,
10235 ada_primitive_type_char
,
10236 ada_primitive_type_float
,
10237 ada_primitive_type_double
,
10238 ada_primitive_type_void
,
10239 ada_primitive_type_long_long
,
10240 ada_primitive_type_long_double
,
10241 ada_primitive_type_natural
,
10242 ada_primitive_type_positive
,
10243 ada_primitive_type_system_address
,
10244 nr_ada_primitive_types
10248 ada_language_arch_info (struct gdbarch
*current_gdbarch
,
10249 struct language_arch_info
*lai
)
10251 const struct builtin_type
*builtin
= builtin_type (current_gdbarch
);
10252 lai
->primitive_type_vector
10253 = GDBARCH_OBSTACK_CALLOC (current_gdbarch
, nr_ada_primitive_types
+ 1,
10255 lai
->primitive_type_vector
[ada_primitive_type_int
] =
10256 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10257 0, "integer", (struct objfile
*) NULL
);
10258 lai
->primitive_type_vector
[ada_primitive_type_long
] =
10259 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10260 0, "long_integer", (struct objfile
*) NULL
);
10261 lai
->primitive_type_vector
[ada_primitive_type_short
] =
10262 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10263 0, "short_integer", (struct objfile
*) NULL
);
10264 lai
->primitive_type_vector
[ada_primitive_type_char
] =
10265 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10266 0, "character", (struct objfile
*) NULL
);
10267 lai
->string_char_type
= builtin
->builtin_char
;
10268 lai
->primitive_type_vector
[ada_primitive_type_float
] =
10269 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
10270 0, "float", (struct objfile
*) NULL
);
10271 lai
->primitive_type_vector
[ada_primitive_type_double
] =
10272 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10273 0, "long_float", (struct objfile
*) NULL
);
10274 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
10275 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10276 0, "long_long_integer", (struct objfile
*) NULL
);
10277 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
10278 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10279 0, "long_long_float", (struct objfile
*) NULL
);
10280 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
10281 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10282 0, "natural", (struct objfile
*) NULL
);
10283 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
10284 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10285 0, "positive", (struct objfile
*) NULL
);
10286 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
10288 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
10289 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10290 (struct objfile
*) NULL
));
10291 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
10292 = "system__address";
10295 /* Language vector */
10297 /* Not really used, but needed in the ada_language_defn. */
10300 emit_char (int c
, struct ui_file
*stream
, int quoter
)
10302 ada_emit_char (c
, stream
, quoter
, 1);
10308 warnings_issued
= 0;
10309 return ada_parse ();
10312 static const struct exp_descriptor ada_exp_descriptor
= {
10314 ada_operator_length
,
10316 ada_dump_subexp_body
,
10317 ada_evaluate_subexp
10320 const struct language_defn ada_language_defn
= {
10321 "ada", /* Language name */
10326 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
10327 that's not quite what this means. */
10330 ada_lookup_minimal_symbol
,
10331 #endif /* GNAT_GDB */
10333 &ada_exp_descriptor
,
10337 ada_printchar
, /* Print a character constant */
10338 ada_printstr
, /* Function to print string constant */
10339 emit_char
, /* Function to print single char (not used) */
10340 ada_create_fundamental_type
, /* Create fundamental type in this language */
10341 ada_print_type
, /* Print a type using appropriate syntax */
10342 ada_val_print
, /* Print a value using appropriate syntax */
10343 ada_value_print
, /* Print a top-level value */
10344 NULL
, /* Language specific skip_trampoline */
10345 NULL
, /* value_of_this */
10346 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
10347 basic_lookup_transparent_type
, /* lookup_transparent_type */
10348 ada_la_decode
, /* Language specific symbol demangler */
10349 NULL
, /* Language specific class_name_from_physname */
10350 ada_op_print_tab
, /* expression operators for printing */
10351 0, /* c-style arrays */
10352 1, /* String lower bound */
10354 ada_get_gdb_completer_word_break_characters
,
10355 ada_language_arch_info
,
10357 ada_translate_error_message
, /* Substitute Ada-specific terminology
10358 in errors and warnings. */
10359 #endif /* GNAT_GDB */
10364 _initialize_ada_language (void)
10366 add_language (&ada_language_defn
);
10368 varsize_limit
= 65536;
10370 add_setshow_uinteger_cmd ("varsize-limit", class_support
,
10372 Set the maximum number of bytes allowed in a dynamic-sized object.", "\
10373 Show the maximum number of bytes allowed in a dynamic-sized object.",
10374 NULL
, NULL
, &setlist
, &showlist
);
10375 obstack_init (&cache_space
);
10376 #endif /* GNAT_GDB */
10378 obstack_init (&symbol_list_obstack
);
10380 decoded_names_store
= htab_create_alloc
10381 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
10382 NULL
, xcalloc
, xfree
);