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. */
24 #include "gdb_string.h"
28 #include "gdb_regex.h"
33 #include "expression.h"
34 #include "parser-defs.h"
40 #include "breakpoint.h"
43 #include "gdb_obstack.h"
45 #include "completer.h"
52 #include "dictionary.h"
54 #ifndef ADA_RETAIN_DOTS
55 #define ADA_RETAIN_DOTS 0
58 /* Define whether or not the C operator '/' truncates towards zero for
59 differently signed operands (truncation direction is undefined in C).
60 Copied from valarith.c. */
62 #ifndef TRUNCATION_TOWARDS_ZERO
63 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
67 static void extract_string (CORE_ADDR addr
, char *buf
);
69 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
71 static void modify_general_field (char *, LONGEST
, int, int);
73 static struct type
*desc_base_type (struct type
*);
75 static struct type
*desc_bounds_type (struct type
*);
77 static struct value
*desc_bounds (struct value
*);
79 static int fat_pntr_bounds_bitpos (struct type
*);
81 static int fat_pntr_bounds_bitsize (struct type
*);
83 static struct type
*desc_data_type (struct type
*);
85 static struct value
*desc_data (struct value
*);
87 static int fat_pntr_data_bitpos (struct type
*);
89 static int fat_pntr_data_bitsize (struct type
*);
91 static struct value
*desc_one_bound (struct value
*, int, int);
93 static int desc_bound_bitpos (struct type
*, int, int);
95 static int desc_bound_bitsize (struct type
*, int, int);
97 static struct type
*desc_index_type (struct type
*, int);
99 static int desc_arity (struct type
*);
101 static int ada_type_match (struct type
*, struct type
*, int);
103 static int ada_args_match (struct symbol
*, struct value
**, int);
105 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
107 static struct value
*convert_actual (struct value
*, struct type
*,
110 static struct value
*make_array_descriptor (struct type
*, struct value
*,
113 static void ada_add_block_symbols (struct obstack
*,
114 struct block
*, const char *,
115 domain_enum
, struct objfile
*,
116 struct symtab
*, int);
118 static int is_nonfunction (struct ada_symbol_info
*, int);
120 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
121 struct block
*, struct symtab
*);
123 static int num_defns_collected (struct obstack
*);
125 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
127 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
128 *, const char *, int,
131 static struct symtab
*symtab_for_sym (struct symbol
*);
133 static struct value
*resolve_subexp (struct expression
**, int *, int,
136 static void replace_operator_with_call (struct expression
**, int, int, int,
137 struct symbol
*, struct block
*);
139 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
141 static char *ada_op_name (enum exp_opcode
);
143 static const char *ada_decoded_op_name (enum exp_opcode
);
145 static int numeric_type_p (struct type
*);
147 static int integer_type_p (struct type
*);
149 static int scalar_type_p (struct type
*);
151 static int discrete_type_p (struct type
*);
153 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
156 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
159 static struct value
*evaluate_subexp_type (struct expression
*, int *);
161 static int is_dynamic_field (struct type
*, int);
163 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
164 CORE_ADDR
, struct value
*);
166 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
168 static struct type
*to_fixed_range_type (char *, struct value
*,
171 static struct type
*to_static_fixed_type (struct type
*);
173 static struct value
*unwrap_value (struct value
*);
175 static struct type
*packed_array_type (struct type
*, long *);
177 static struct type
*decode_packed_array_type (struct type
*);
179 static struct value
*decode_packed_array (struct value
*);
181 static struct value
*value_subscript_packed (struct value
*, int,
184 static struct value
*coerce_unspec_val_to_type (struct value
*,
187 static struct value
*get_var_value (char *, char *);
189 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
191 static int equiv_types (struct type
*, struct type
*);
193 static int is_name_suffix (const char *);
195 static int wild_match (const char *, int, const char *);
197 static struct value
*ada_coerce_ref (struct value
*);
199 static LONGEST
pos_atr (struct value
*);
201 static struct value
*value_pos_atr (struct value
*);
203 static struct value
*value_val_atr (struct type
*, struct value
*);
205 static struct symbol
*standard_lookup (const char *, const struct block
*,
208 static struct value
*ada_search_struct_field (char *, struct value
*, int,
211 static struct value
*ada_value_primitive_field (struct value
*, int, int,
214 static int find_struct_field (char *, struct type
*, int,
215 struct type
**, int *, int *, int *);
217 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
220 static struct value
*ada_to_fixed_value (struct value
*);
222 static int ada_resolve_function (struct ada_symbol_info
*, int,
223 struct value
**, int, const char *,
226 static struct value
*ada_coerce_to_simple_array (struct value
*);
228 static int ada_is_direct_array_type (struct type
*);
230 static void ada_language_arch_info (struct gdbarch
*,
231 struct language_arch_info
*);
235 /* Maximum-sized dynamic type. */
236 static unsigned int varsize_limit
;
238 /* FIXME: brobecker/2003-09-17: No longer a const because it is
239 returned by a function that does not return a const char *. */
240 static char *ada_completer_word_break_characters
=
242 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
244 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
247 /* The name of the symbol to use to get the name of the main subprogram. */
248 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
249 = "__gnat_ada_main_program_name";
251 /* The name of the runtime function called when an exception is raised. */
252 static const char raise_sym_name
[] = "__gnat_raise_nodefer_with_msg";
254 /* The name of the runtime function called when an unhandled exception
256 static const char raise_unhandled_sym_name
[] = "__gnat_unhandled_exception";
258 /* The name of the runtime function called when an assert failure is
260 static const char raise_assert_sym_name
[] =
261 "system__assertions__raise_assert_failure";
263 /* When GDB stops on an unhandled exception, GDB will go up the stack until
264 if finds a frame corresponding to this function, in order to extract the
265 name of the exception that has been raised from one of the parameters. */
266 static const char process_raise_exception_name
[] =
267 "ada__exceptions__process_raise_exception";
269 /* A string that reflects the longest exception expression rewrite,
270 aside from the exception name. */
271 static const char longest_exception_template
[] =
272 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
274 /* Limit on the number of warnings to raise per expression evaluation. */
275 static int warning_limit
= 2;
277 /* Number of warning messages issued; reset to 0 by cleanups after
278 expression evaluation. */
279 static int warnings_issued
= 0;
281 static const char *known_runtime_file_name_patterns
[] = {
282 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
285 static const char *known_auxiliary_function_name_patterns
[] = {
286 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
289 /* Space for allocating results of ada_lookup_symbol_list. */
290 static struct obstack symbol_list_obstack
;
296 ada_get_gdb_completer_word_break_characters (void)
298 return ada_completer_word_break_characters
;
301 /* Read the string located at ADDR from the inferior and store the
305 extract_string (CORE_ADDR addr
, char *buf
)
309 /* Loop, reading one byte at a time, until we reach the '\000'
310 end-of-string marker. */
313 target_read_memory (addr
+ char_index
* sizeof (char),
314 buf
+ char_index
* sizeof (char), sizeof (char));
317 while (buf
[char_index
- 1] != '\000');
320 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
321 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
322 updating *OLD_VECT and *SIZE as necessary. */
325 grow_vect (void **old_vect
, size_t * size
, size_t min_size
, int element_size
)
327 if (*size
< min_size
)
330 if (*size
< min_size
)
332 *old_vect
= xrealloc (*old_vect
, *size
* element_size
);
336 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
337 suffix of FIELD_NAME beginning "___". */
340 field_name_match (const char *field_name
, const char *target
)
342 int len
= strlen (target
);
344 (strncmp (field_name
, target
, len
) == 0
345 && (field_name
[len
] == '\0'
346 || (strncmp (field_name
+ len
, "___", 3) == 0
347 && strcmp (field_name
+ strlen (field_name
) - 6,
352 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
353 FIELD_NAME, and return its index. This function also handles fields
354 whose name have ___ suffixes because the compiler sometimes alters
355 their name by adding such a suffix to represent fields with certain
356 constraints. If the field could not be found, return a negative
357 number if MAYBE_MISSING is set. Otherwise raise an error. */
360 ada_get_field_index (const struct type
*type
, const char *field_name
,
364 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
365 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
369 error ("Unable to find field %s in struct %s. Aborting",
370 field_name
, TYPE_NAME (type
));
375 /* The length of the prefix of NAME prior to any "___" suffix. */
378 ada_name_prefix_len (const char *name
)
384 const char *p
= strstr (name
, "___");
386 return strlen (name
);
392 /* Return non-zero if SUFFIX is a suffix of STR.
393 Return zero if STR is null. */
396 is_suffix (const char *str
, const char *suffix
)
402 len2
= strlen (suffix
);
403 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
406 /* Create a value of type TYPE whose contents come from VALADDR, if it
407 is non-null, and whose memory address (in the inferior) is
411 value_from_contents_and_address (struct type
*type
, char *valaddr
,
414 struct value
*v
= allocate_value (type
);
418 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
419 VALUE_ADDRESS (v
) = address
;
421 VALUE_LVAL (v
) = lval_memory
;
425 /* The contents of value VAL, treated as a value of type TYPE. The
426 result is an lval in memory if VAL is. */
428 static struct value
*
429 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
431 type
= ada_check_typedef (type
);
432 if (VALUE_TYPE (val
) == type
)
436 struct value
*result
;
438 /* Make sure that the object size is not unreasonable before
439 trying to allocate some memory for it. */
440 if (TYPE_LENGTH (type
) > varsize_limit
)
441 error ("object size is larger than varsize-limit");
443 result
= allocate_value (type
);
444 VALUE_LVAL (result
) = VALUE_LVAL (val
);
445 VALUE_BITSIZE (result
) = VALUE_BITSIZE (val
);
446 VALUE_BITPOS (result
) = VALUE_BITPOS (val
);
447 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + VALUE_OFFSET (val
);
449 || TYPE_LENGTH (type
) > TYPE_LENGTH (VALUE_TYPE (val
)))
450 VALUE_LAZY (result
) = 1;
452 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
),
459 cond_offset_host (char *valaddr
, long offset
)
464 return valaddr
+ offset
;
468 cond_offset_target (CORE_ADDR address
, long offset
)
473 return address
+ offset
;
476 /* Issue a warning (as for the definition of warning in utils.c, but
477 with exactly one argument rather than ...), unless the limit on the
478 number of warnings has passed during the evaluation of the current
481 lim_warning (const char *format
, long arg
)
483 warnings_issued
+= 1;
484 if (warnings_issued
<= warning_limit
)
485 warning (format
, arg
);
488 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
489 gdbtypes.h, but some of the necessary definitions in that file
490 seem to have gone missing. */
492 /* Maximum value of a SIZE-byte signed integer type. */
494 max_of_size (int size
)
496 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
497 return top_bit
| (top_bit
- 1);
500 /* Minimum value of a SIZE-byte signed integer type. */
502 min_of_size (int size
)
504 return -max_of_size (size
) - 1;
507 /* Maximum value of a SIZE-byte unsigned integer type. */
509 umax_of_size (int size
)
511 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
512 return top_bit
| (top_bit
- 1);
515 /* Maximum value of integral type T, as a signed quantity. */
517 max_of_type (struct type
*t
)
519 if (TYPE_UNSIGNED (t
))
520 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
522 return max_of_size (TYPE_LENGTH (t
));
525 /* Minimum value of integral type T, as a signed quantity. */
527 min_of_type (struct type
*t
)
529 if (TYPE_UNSIGNED (t
))
532 return min_of_size (TYPE_LENGTH (t
));
535 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
536 static struct value
*
537 discrete_type_high_bound (struct type
*type
)
539 switch (TYPE_CODE (type
))
541 case TYPE_CODE_RANGE
:
542 return value_from_longest (TYPE_TARGET_TYPE (type
),
543 TYPE_HIGH_BOUND (type
));
546 value_from_longest (type
,
547 TYPE_FIELD_BITPOS (type
,
548 TYPE_NFIELDS (type
) - 1));
550 return value_from_longest (type
, max_of_type (type
));
552 error ("Unexpected type in discrete_type_high_bound.");
556 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
557 static struct value
*
558 discrete_type_low_bound (struct type
*type
)
560 switch (TYPE_CODE (type
))
562 case TYPE_CODE_RANGE
:
563 return value_from_longest (TYPE_TARGET_TYPE (type
),
564 TYPE_LOW_BOUND (type
));
566 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
568 return value_from_longest (type
, min_of_type (type
));
570 error ("Unexpected type in discrete_type_low_bound.");
574 /* The identity on non-range types. For range types, the underlying
575 non-range scalar type. */
578 base_type (struct type
*type
)
580 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
582 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
584 type
= TYPE_TARGET_TYPE (type
);
590 /* Language Selection */
592 /* If the main program is in Ada, return language_ada, otherwise return LANG
593 (the main program is in Ada iif the adainit symbol is found).
595 MAIN_PST is not used. */
598 ada_update_initial_language (enum language lang
,
599 struct partial_symtab
*main_pst
)
601 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
602 (struct objfile
*) NULL
) != NULL
)
608 /* If the main procedure is written in Ada, then return its name.
609 The result is good until the next call. Return NULL if the main
610 procedure doesn't appear to be in Ada. */
615 struct minimal_symbol
*msym
;
616 CORE_ADDR main_program_name_addr
;
617 static char main_program_name
[1024];
619 /* For Ada, the name of the main procedure is stored in a specific
620 string constant, generated by the binder. Look for that symbol,
621 extract its address, and then read that string. If we didn't find
622 that string, then most probably the main procedure is not written
624 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
628 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
629 if (main_program_name_addr
== 0)
630 error ("Invalid address for Ada main program name.");
632 extract_string (main_program_name_addr
, main_program_name
);
633 return main_program_name
;
636 /* The main procedure doesn't seem to be in Ada. */
642 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
645 const struct ada_opname_map ada_opname_table
[] = {
646 {"Oadd", "\"+\"", BINOP_ADD
},
647 {"Osubtract", "\"-\"", BINOP_SUB
},
648 {"Omultiply", "\"*\"", BINOP_MUL
},
649 {"Odivide", "\"/\"", BINOP_DIV
},
650 {"Omod", "\"mod\"", BINOP_MOD
},
651 {"Orem", "\"rem\"", BINOP_REM
},
652 {"Oexpon", "\"**\"", BINOP_EXP
},
653 {"Olt", "\"<\"", BINOP_LESS
},
654 {"Ole", "\"<=\"", BINOP_LEQ
},
655 {"Ogt", "\">\"", BINOP_GTR
},
656 {"Oge", "\">=\"", BINOP_GEQ
},
657 {"Oeq", "\"=\"", BINOP_EQUAL
},
658 {"One", "\"/=\"", BINOP_NOTEQUAL
},
659 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
660 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
661 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
662 {"Oconcat", "\"&\"", BINOP_CONCAT
},
663 {"Oabs", "\"abs\"", UNOP_ABS
},
664 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
665 {"Oadd", "\"+\"", UNOP_PLUS
},
666 {"Osubtract", "\"-\"", UNOP_NEG
},
670 /* Return non-zero if STR should be suppressed in info listings. */
673 is_suppressed_name (const char *str
)
675 if (strncmp (str
, "_ada_", 5) == 0)
677 if (str
[0] == '_' || str
[0] == '\000')
682 const char *suffix
= strstr (str
, "___");
683 if (suffix
!= NULL
&& suffix
[3] != 'X')
686 suffix
= str
+ strlen (str
);
687 for (p
= suffix
- 1; p
!= str
; p
-= 1)
691 if (p
[0] == 'X' && p
[-1] != '_')
695 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
696 if (strncmp (ada_opname_table
[i
].encoded
, p
,
697 strlen (ada_opname_table
[i
].encoded
)) == 0)
706 /* The "encoded" form of DECODED, according to GNAT conventions.
707 The result is valid until the next call to ada_encode. */
710 ada_encode (const char *decoded
)
712 static char *encoding_buffer
= NULL
;
713 static size_t encoding_buffer_size
= 0;
720 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
721 2 * strlen (decoded
) + 10);
724 for (p
= decoded
; *p
!= '\0'; p
+= 1)
726 if (!ADA_RETAIN_DOTS
&& *p
== '.')
728 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
733 const struct ada_opname_map
*mapping
;
735 for (mapping
= ada_opname_table
;
736 mapping
->encoded
!= NULL
737 && strncmp (mapping
->decoded
, p
,
738 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
740 if (mapping
->encoded
== NULL
)
741 error ("invalid Ada operator name: %s", p
);
742 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
743 k
+= strlen (mapping
->encoded
);
748 encoding_buffer
[k
] = *p
;
753 encoding_buffer
[k
] = '\0';
754 return encoding_buffer
;
757 /* Return NAME folded to lower case, or, if surrounded by single
758 quotes, unfolded, but with the quotes stripped away. Result good
762 ada_fold_name (const char *name
)
764 static char *fold_buffer
= NULL
;
765 static size_t fold_buffer_size
= 0;
767 int len
= strlen (name
);
768 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
772 strncpy (fold_buffer
, name
+ 1, len
- 2);
773 fold_buffer
[len
- 2] = '\000';
778 for (i
= 0; i
<= len
; i
+= 1)
779 fold_buffer
[i
] = tolower (name
[i
]);
786 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
787 These are suffixes introduced by GNAT5 to nested subprogram
788 names, and do not serve any purpose for the debugger.
789 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
790 2. Convert other instances of embedded "__" to `.'.
791 3. Discard leading _ada_.
792 4. Convert operator names to the appropriate quoted symbols.
793 5. Remove everything after first ___ if it is followed by
795 6. Replace TK__ with __, and a trailing B or TKB with nothing.
796 7. Put symbols that should be suppressed in <...> brackets.
797 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
799 The resulting string is valid until the next call of ada_decode.
800 If the string is unchanged by demangling, the original string pointer
804 ada_decode (const char *encoded
)
811 static char *decoding_buffer
= NULL
;
812 static size_t decoding_buffer_size
= 0;
814 if (strncmp (encoded
, "_ada_", 5) == 0)
817 if (encoded
[0] == '_' || encoded
[0] == '<')
820 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
821 len0
= strlen (encoded
);
822 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
825 while (i
> 0 && isdigit (encoded
[i
]))
827 if (i
>= 0 && encoded
[i
] == '.')
829 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
833 /* Remove the ___X.* suffix if present. Do not forget to verify that
834 the suffix is located before the current "end" of ENCODED. We want
835 to avoid re-matching parts of ENCODED that have previously been
836 marked as discarded (by decrementing LEN0). */
837 p
= strstr (encoded
, "___");
838 if (p
!= NULL
&& p
- encoded
< len0
- 3)
846 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
849 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
852 /* Make decoded big enough for possible expansion by operator name. */
853 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
854 decoded
= decoding_buffer
;
856 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
859 while ((i
>= 0 && isdigit (encoded
[i
]))
860 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
862 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
864 else if (encoded
[i
] == '$')
868 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
869 decoded
[j
] = encoded
[i
];
874 if (at_start_name
&& encoded
[i
] == 'O')
877 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
879 int op_len
= strlen (ada_opname_table
[k
].encoded
);
880 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
882 && !isalnum (encoded
[i
+ op_len
]))
884 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
887 j
+= strlen (ada_opname_table
[k
].decoded
);
891 if (ada_opname_table
[k
].encoded
!= NULL
)
896 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
898 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
902 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
906 else if (!ADA_RETAIN_DOTS
907 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
916 decoded
[j
] = encoded
[i
];
923 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
924 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
927 if (strcmp (decoded
, encoded
) == 0)
933 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
934 decoded
= decoding_buffer
;
935 if (encoded
[0] == '<')
936 strcpy (decoded
, encoded
);
938 sprintf (decoded
, "<%s>", encoded
);
943 /* Table for keeping permanent unique copies of decoded names. Once
944 allocated, names in this table are never released. While this is a
945 storage leak, it should not be significant unless there are massive
946 changes in the set of decoded names in successive versions of a
947 symbol table loaded during a single session. */
948 static struct htab
*decoded_names_store
;
950 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
951 in the language-specific part of GSYMBOL, if it has not been
952 previously computed. Tries to save the decoded name in the same
953 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
954 in any case, the decoded symbol has a lifetime at least that of
956 The GSYMBOL parameter is "mutable" in the C++ sense: logically
957 const, but nevertheless modified to a semantically equivalent form
958 when a decoded name is cached in it.
962 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
965 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
966 if (*resultp
== NULL
)
968 const char *decoded
= ada_decode (gsymbol
->name
);
969 if (gsymbol
->bfd_section
!= NULL
)
971 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
974 struct objfile
*objf
;
977 if (obfd
== objf
->obfd
)
979 *resultp
= obsavestring (decoded
, strlen (decoded
),
980 &objf
->objfile_obstack
);
986 /* Sometimes, we can't find a corresponding objfile, in which
987 case, we put the result on the heap. Since we only decode
988 when needed, we hope this usually does not cause a
989 significant memory leak (FIXME). */
990 if (*resultp
== NULL
)
992 char **slot
= (char **) htab_find_slot (decoded_names_store
,
995 *slot
= xstrdup (decoded
);
1004 ada_la_decode (const char *encoded
, int options
)
1006 return xstrdup (ada_decode (encoded
));
1009 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1010 suffixes that encode debugging information or leading _ada_ on
1011 SYM_NAME (see is_name_suffix commentary for the debugging
1012 information that is ignored). If WILD, then NAME need only match a
1013 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1014 either argument is NULL. */
1017 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1019 if (sym_name
== NULL
|| name
== NULL
)
1022 return wild_match (name
, strlen (name
), sym_name
);
1025 int len_name
= strlen (name
);
1026 return (strncmp (sym_name
, name
, len_name
) == 0
1027 && is_name_suffix (sym_name
+ len_name
))
1028 || (strncmp (sym_name
, "_ada_", 5) == 0
1029 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1030 && is_name_suffix (sym_name
+ len_name
+ 5));
1034 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1035 suppressed in info listings. */
1038 ada_suppress_symbol_printing (struct symbol
*sym
)
1040 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1043 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1049 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1051 static char *bound_name
[] = {
1052 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1053 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1056 /* Maximum number of array dimensions we are prepared to handle. */
1058 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1060 /* Like modify_field, but allows bitpos > wordlength. */
1063 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1065 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1069 /* The desc_* routines return primitive portions of array descriptors
1072 /* The descriptor or array type, if any, indicated by TYPE; removes
1073 level of indirection, if needed. */
1075 static struct type
*
1076 desc_base_type (struct type
*type
)
1080 type
= ada_check_typedef (type
);
1082 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1083 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1084 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1089 /* True iff TYPE indicates a "thin" array pointer type. */
1092 is_thin_pntr (struct type
*type
)
1095 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1096 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1099 /* The descriptor type for thin pointer type TYPE. */
1101 static struct type
*
1102 thin_descriptor_type (struct type
*type
)
1104 struct type
*base_type
= desc_base_type (type
);
1105 if (base_type
== NULL
)
1107 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1111 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1112 if (alt_type
== NULL
)
1119 /* A pointer to the array data for thin-pointer value VAL. */
1121 static struct value
*
1122 thin_data_pntr (struct value
*val
)
1124 struct type
*type
= VALUE_TYPE (val
);
1125 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1126 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1129 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1130 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
1133 /* True iff TYPE indicates a "thick" array pointer type. */
1136 is_thick_pntr (struct type
*type
)
1138 type
= desc_base_type (type
);
1139 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1140 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1143 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1144 pointer to one, the type of its bounds data; otherwise, NULL. */
1146 static struct type
*
1147 desc_bounds_type (struct type
*type
)
1151 type
= desc_base_type (type
);
1155 else if (is_thin_pntr (type
))
1157 type
= thin_descriptor_type (type
);
1160 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1162 return ada_check_typedef (r
);
1164 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1166 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1168 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1173 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1174 one, a pointer to its bounds data. Otherwise NULL. */
1176 static struct value
*
1177 desc_bounds (struct value
*arr
)
1179 struct type
*type
= ada_check_typedef (VALUE_TYPE (arr
));
1180 if (is_thin_pntr (type
))
1182 struct type
*bounds_type
=
1183 desc_bounds_type (thin_descriptor_type (type
));
1186 if (desc_bounds_type
== NULL
)
1187 error ("Bad GNAT array descriptor");
1189 /* NOTE: The following calculation is not really kosher, but
1190 since desc_type is an XVE-encoded type (and shouldn't be),
1191 the correct calculation is a real pain. FIXME (and fix GCC). */
1192 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1193 addr
= value_as_long (arr
);
1195 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
1198 value_from_longest (lookup_pointer_type (bounds_type
),
1199 addr
- TYPE_LENGTH (bounds_type
));
1202 else if (is_thick_pntr (type
))
1203 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1204 "Bad GNAT array descriptor");
1209 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1210 position of the field containing the address of the bounds data. */
1213 fat_pntr_bounds_bitpos (struct type
*type
)
1215 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1218 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1219 size of the field containing the address of the bounds data. */
1222 fat_pntr_bounds_bitsize (struct type
*type
)
1224 type
= desc_base_type (type
);
1226 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1227 return TYPE_FIELD_BITSIZE (type
, 1);
1229 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1232 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1233 pointer to one, the type of its array data (a
1234 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1235 ada_type_of_array to get an array type with bounds data. */
1237 static struct type
*
1238 desc_data_type (struct type
*type
)
1240 type
= desc_base_type (type
);
1242 /* NOTE: The following is bogus; see comment in desc_bounds. */
1243 if (is_thin_pntr (type
))
1244 return lookup_pointer_type
1245 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1246 else if (is_thick_pntr (type
))
1247 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1252 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1255 static struct value
*
1256 desc_data (struct value
*arr
)
1258 struct type
*type
= VALUE_TYPE (arr
);
1259 if (is_thin_pntr (type
))
1260 return thin_data_pntr (arr
);
1261 else if (is_thick_pntr (type
))
1262 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1263 "Bad GNAT array descriptor");
1269 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1270 position of the field containing the address of the data. */
1273 fat_pntr_data_bitpos (struct type
*type
)
1275 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1278 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1279 size of the field containing the address of the data. */
1282 fat_pntr_data_bitsize (struct type
*type
)
1284 type
= desc_base_type (type
);
1286 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1287 return TYPE_FIELD_BITSIZE (type
, 0);
1289 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1292 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1293 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1294 bound, if WHICH is 1. The first bound is I=1. */
1296 static struct value
*
1297 desc_one_bound (struct value
*bounds
, int i
, int which
)
1299 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1300 "Bad GNAT array descriptor bounds");
1303 /* If BOUNDS is an array-bounds structure type, return the bit position
1304 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1305 bound, if WHICH is 1. The first bound is I=1. */
1308 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1310 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1313 /* If BOUNDS is an array-bounds structure type, return the bit field size
1314 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1315 bound, if WHICH is 1. The first bound is I=1. */
1318 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1320 type
= desc_base_type (type
);
1322 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1323 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1325 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1328 /* If TYPE is the type of an array-bounds structure, the type of its
1329 Ith bound (numbering from 1). Otherwise, NULL. */
1331 static struct type
*
1332 desc_index_type (struct type
*type
, int i
)
1334 type
= desc_base_type (type
);
1336 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1337 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1342 /* The number of index positions in the array-bounds type TYPE.
1343 Return 0 if TYPE is NULL. */
1346 desc_arity (struct type
*type
)
1348 type
= desc_base_type (type
);
1351 return TYPE_NFIELDS (type
) / 2;
1355 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1356 an array descriptor type (representing an unconstrained array
1360 ada_is_direct_array_type (struct type
*type
)
1364 type
= ada_check_typedef (type
);
1365 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1366 || ada_is_array_descriptor_type (type
));
1369 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1372 ada_is_simple_array_type (struct type
*type
)
1376 type
= ada_check_typedef (type
);
1377 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1378 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1379 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1382 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1385 ada_is_array_descriptor_type (struct type
*type
)
1387 struct type
*data_type
= desc_data_type (type
);
1391 type
= ada_check_typedef (type
);
1394 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1395 && TYPE_TARGET_TYPE (data_type
) != NULL
1396 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1397 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1398 && desc_arity (desc_bounds_type (type
)) > 0;
1401 /* Non-zero iff type is a partially mal-formed GNAT array
1402 descriptor. FIXME: This is to compensate for some problems with
1403 debugging output from GNAT. Re-examine periodically to see if it
1407 ada_is_bogus_array_descriptor (struct type
*type
)
1411 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1412 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1413 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1414 && !ada_is_array_descriptor_type (type
);
1418 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1419 (fat pointer) returns the type of the array data described---specifically,
1420 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1421 in from the descriptor; otherwise, they are left unspecified. If
1422 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1423 returns NULL. The result is simply the type of ARR if ARR is not
1426 ada_type_of_array (struct value
*arr
, int bounds
)
1428 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1429 return decode_packed_array_type (VALUE_TYPE (arr
));
1431 if (!ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1432 return VALUE_TYPE (arr
);
1436 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1439 struct type
*elt_type
;
1441 struct value
*descriptor
;
1442 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1444 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1445 arity
= ada_array_arity (VALUE_TYPE (arr
));
1447 if (elt_type
== NULL
|| arity
== 0)
1448 return ada_check_typedef (VALUE_TYPE (arr
));
1450 descriptor
= desc_bounds (arr
);
1451 if (value_as_long (descriptor
) == 0)
1455 struct type
*range_type
= alloc_type (objf
);
1456 struct type
*array_type
= alloc_type (objf
);
1457 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1458 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1461 create_range_type (range_type
, VALUE_TYPE (low
),
1462 (int) value_as_long (low
),
1463 (int) value_as_long (high
));
1464 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1467 return lookup_pointer_type (elt_type
);
1471 /* If ARR does not represent an array, returns ARR unchanged.
1472 Otherwise, returns either a standard GDB array with bounds set
1473 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1474 GDB array. Returns NULL if ARR is a null fat pointer. */
1477 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1479 if (ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1481 struct type
*arrType
= ada_type_of_array (arr
, 1);
1482 if (arrType
== NULL
)
1484 return value_cast (arrType
, value_copy (desc_data (arr
)));
1486 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1487 return decode_packed_array (arr
);
1492 /* If ARR does not represent an array, returns ARR unchanged.
1493 Otherwise, returns a standard GDB array describing ARR (which may
1494 be ARR itself if it already is in the proper form). */
1496 static struct value
*
1497 ada_coerce_to_simple_array (struct value
*arr
)
1499 if (ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1501 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1503 error ("Bounds unavailable for null array pointer.");
1504 return value_ind (arrVal
);
1506 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1507 return decode_packed_array (arr
);
1512 /* If TYPE represents a GNAT array type, return it translated to an
1513 ordinary GDB array type (possibly with BITSIZE fields indicating
1514 packing). For other types, is the identity. */
1517 ada_coerce_to_simple_array_type (struct type
*type
)
1519 struct value
*mark
= value_mark ();
1520 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1521 struct type
*result
;
1522 VALUE_TYPE (dummy
) = type
;
1523 result
= ada_type_of_array (dummy
, 0);
1524 value_free_to_mark (mark
);
1528 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1531 ada_is_packed_array_type (struct type
*type
)
1535 type
= desc_base_type (type
);
1536 type
= ada_check_typedef (type
);
1538 ada_type_name (type
) != NULL
1539 && strstr (ada_type_name (type
), "___XP") != NULL
;
1542 /* Given that TYPE is a standard GDB array type with all bounds filled
1543 in, and that the element size of its ultimate scalar constituents
1544 (that is, either its elements, or, if it is an array of arrays, its
1545 elements' elements, etc.) is *ELT_BITS, return an identical type,
1546 but with the bit sizes of its elements (and those of any
1547 constituent arrays) recorded in the BITSIZE components of its
1548 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1551 static struct type
*
1552 packed_array_type (struct type
*type
, long *elt_bits
)
1554 struct type
*new_elt_type
;
1555 struct type
*new_type
;
1556 LONGEST low_bound
, high_bound
;
1558 type
= ada_check_typedef (type
);
1559 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1562 new_type
= alloc_type (TYPE_OBJFILE (type
));
1563 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1565 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1566 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1567 TYPE_NAME (new_type
) = ada_type_name (type
);
1569 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1570 &low_bound
, &high_bound
) < 0)
1571 low_bound
= high_bound
= 0;
1572 if (high_bound
< low_bound
)
1573 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1576 *elt_bits
*= (high_bound
- low_bound
+ 1);
1577 TYPE_LENGTH (new_type
) =
1578 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1581 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1585 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1587 static struct type
*
1588 decode_packed_array_type (struct type
*type
)
1591 struct block
**blocks
;
1592 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
1593 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1594 char *tail
= strstr (raw_name
, "___XP");
1595 struct type
*shadow_type
;
1599 type
= desc_base_type (type
);
1601 memcpy (name
, raw_name
, tail
- raw_name
);
1602 name
[tail
- raw_name
] = '\000';
1604 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1605 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1607 lim_warning ("could not find bounds information on packed array", 0);
1610 shadow_type
= SYMBOL_TYPE (sym
);
1612 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1614 lim_warning ("could not understand bounds information on packed array",
1619 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1622 ("could not understand bit size information on packed array", 0);
1626 return packed_array_type (shadow_type
, &bits
);
1629 /* Given that ARR is a struct value *indicating a GNAT packed array,
1630 returns a simple array that denotes that array. Its type is a
1631 standard GDB array type except that the BITSIZEs of the array
1632 target types are set to the number of bits in each element, and the
1633 type length is set appropriately. */
1635 static struct value
*
1636 decode_packed_array (struct value
*arr
)
1640 arr
= ada_coerce_ref (arr
);
1641 if (TYPE_CODE (VALUE_TYPE (arr
)) == TYPE_CODE_PTR
)
1642 arr
= ada_value_ind (arr
);
1644 type
= decode_packed_array_type (VALUE_TYPE (arr
));
1647 error ("can't unpack array");
1651 if (BITS_BIG_ENDIAN
&& ada_is_modular_type (VALUE_TYPE (arr
)))
1653 /* This is a (right-justified) modular type representing a packed
1654 array with no wrapper. In order to interpret the value through
1655 the (left-justified) packed array type we just built, we must
1656 first left-justify it. */
1657 int bit_size
, bit_pos
;
1660 mod
= ada_modulus (VALUE_TYPE (arr
)) - 1;
1667 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (VALUE_TYPE (arr
)) - bit_size
;
1668 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1669 bit_pos
/ HOST_CHAR_BIT
,
1670 bit_pos
% HOST_CHAR_BIT
,
1675 return coerce_unspec_val_to_type (arr
, type
);
1679 /* The value of the element of packed array ARR at the ARITY indices
1680 given in IND. ARR must be a simple array. */
1682 static struct value
*
1683 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1686 int bits
, elt_off
, bit_off
;
1687 long elt_total_bit_offset
;
1688 struct type
*elt_type
;
1692 elt_total_bit_offset
= 0;
1693 elt_type
= ada_check_typedef (VALUE_TYPE (arr
));
1694 for (i
= 0; i
< arity
; i
+= 1)
1696 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1697 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1699 ("attempt to do packed indexing of something other than a packed array");
1702 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1703 LONGEST lowerbound
, upperbound
;
1706 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1708 lim_warning ("don't know bounds of array", 0);
1709 lowerbound
= upperbound
= 0;
1712 idx
= value_as_long (value_pos_atr (ind
[i
]));
1713 if (idx
< lowerbound
|| idx
> upperbound
)
1714 lim_warning ("packed array index %ld out of bounds", (long) idx
);
1715 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1716 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1717 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1720 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1721 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1723 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1725 if (VALUE_LVAL (arr
) == lval_internalvar
)
1726 VALUE_LVAL (v
) = lval_internalvar_component
;
1728 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1732 /* Non-zero iff TYPE includes negative integer values. */
1735 has_negatives (struct type
*type
)
1737 switch (TYPE_CODE (type
))
1742 return !TYPE_UNSIGNED (type
);
1743 case TYPE_CODE_RANGE
:
1744 return TYPE_LOW_BOUND (type
) < 0;
1749 /* Create a new value of type TYPE from the contents of OBJ starting
1750 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1751 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1752 assigning through the result will set the field fetched from.
1753 VALADDR is ignored unless OBJ is NULL, in which case,
1754 VALADDR+OFFSET must address the start of storage containing the
1755 packed value. The value returned in this case is never an lval.
1756 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1759 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1760 int bit_offset
, int bit_size
,
1764 int src
, /* Index into the source area */
1765 targ
, /* Index into the target area */
1766 srcBitsLeft
, /* Number of source bits left to move */
1767 nsrc
, ntarg
, /* Number of source and target bytes */
1768 unusedLS
, /* Number of bits in next significant
1769 byte of source that are unused */
1770 accumSize
; /* Number of meaningful bits in accum */
1771 unsigned char *bytes
; /* First byte containing data to unpack */
1772 unsigned char *unpacked
;
1773 unsigned long accum
; /* Staging area for bits being transferred */
1775 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1776 /* Transmit bytes from least to most significant; delta is the direction
1777 the indices move. */
1778 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1780 type
= ada_check_typedef (type
);
1784 v
= allocate_value (type
);
1785 bytes
= (unsigned char *) (valaddr
+ offset
);
1787 else if (VALUE_LAZY (obj
))
1790 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1791 bytes
= (unsigned char *) alloca (len
);
1792 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1796 v
= allocate_value (type
);
1797 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1802 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1803 if (VALUE_LVAL (obj
) == lval_internalvar
)
1804 VALUE_LVAL (v
) = lval_internalvar_component
;
1805 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1806 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1807 VALUE_BITSIZE (v
) = bit_size
;
1808 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1810 VALUE_ADDRESS (v
) += 1;
1811 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1815 VALUE_BITSIZE (v
) = bit_size
;
1816 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1818 srcBitsLeft
= bit_size
;
1820 ntarg
= TYPE_LENGTH (type
);
1824 memset (unpacked
, 0, TYPE_LENGTH (type
));
1827 else if (BITS_BIG_ENDIAN
)
1830 if (has_negatives (type
)
1831 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1835 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1838 switch (TYPE_CODE (type
))
1840 case TYPE_CODE_ARRAY
:
1841 case TYPE_CODE_UNION
:
1842 case TYPE_CODE_STRUCT
:
1843 /* Non-scalar values must be aligned at a byte boundary... */
1845 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1846 /* ... And are placed at the beginning (most-significant) bytes
1852 targ
= TYPE_LENGTH (type
) - 1;
1858 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1861 unusedLS
= bit_offset
;
1864 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1871 /* Mask for removing bits of the next source byte that are not
1872 part of the value. */
1873 unsigned int unusedMSMask
=
1874 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1876 /* Sign-extend bits for this byte. */
1877 unsigned int signMask
= sign
& ~unusedMSMask
;
1879 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1880 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1881 if (accumSize
>= HOST_CHAR_BIT
)
1883 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1884 accumSize
-= HOST_CHAR_BIT
;
1885 accum
>>= HOST_CHAR_BIT
;
1889 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1896 accum
|= sign
<< accumSize
;
1897 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1898 accumSize
-= HOST_CHAR_BIT
;
1899 accum
>>= HOST_CHAR_BIT
;
1907 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1908 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1911 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
1913 unsigned int accum
, mask
;
1914 int accum_bits
, chunk_size
;
1916 target
+= targ_offset
/ HOST_CHAR_BIT
;
1917 targ_offset
%= HOST_CHAR_BIT
;
1918 source
+= src_offset
/ HOST_CHAR_BIT
;
1919 src_offset
%= HOST_CHAR_BIT
;
1920 if (BITS_BIG_ENDIAN
)
1922 accum
= (unsigned char) *source
;
1924 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1929 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1930 accum_bits
+= HOST_CHAR_BIT
;
1932 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1935 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1936 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1939 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1941 accum_bits
-= chunk_size
;
1948 accum
= (unsigned char) *source
>> src_offset
;
1950 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1954 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1955 accum_bits
+= HOST_CHAR_BIT
;
1957 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1960 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1961 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1963 accum_bits
-= chunk_size
;
1964 accum
>>= chunk_size
;
1972 /* Store the contents of FROMVAL into the location of TOVAL.
1973 Return a new value with the location of TOVAL and contents of
1974 FROMVAL. Handles assignment into packed fields that have
1975 floating-point or non-scalar types. */
1977 static struct value
*
1978 ada_value_assign (struct value
*toval
, struct value
*fromval
)
1980 struct type
*type
= VALUE_TYPE (toval
);
1981 int bits
= VALUE_BITSIZE (toval
);
1983 if (!toval
->modifiable
)
1984 error ("Left operand of assignment is not a modifiable lvalue.");
1988 if (VALUE_LVAL (toval
) == lval_memory
1990 && (TYPE_CODE (type
) == TYPE_CODE_FLT
1991 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
1994 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1995 char *buffer
= (char *) alloca (len
);
1998 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
1999 fromval
= value_cast (type
, fromval
);
2001 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
2002 if (BITS_BIG_ENDIAN
)
2003 move_bits (buffer
, VALUE_BITPOS (toval
),
2004 VALUE_CONTENTS (fromval
),
2005 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
-
2008 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
2010 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
,
2013 val
= value_copy (toval
);
2014 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
2015 TYPE_LENGTH (type
));
2016 VALUE_TYPE (val
) = type
;
2021 return value_assign (toval
, fromval
);
2025 /* The value of the element of array ARR at the ARITY indices given in IND.
2026 ARR may be either a simple array, GNAT array descriptor, or pointer
2030 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2034 struct type
*elt_type
;
2036 elt
= ada_coerce_to_simple_array (arr
);
2038 elt_type
= ada_check_typedef (VALUE_TYPE (elt
));
2039 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2040 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2041 return value_subscript_packed (elt
, arity
, ind
);
2043 for (k
= 0; k
< arity
; k
+= 1)
2045 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2046 error ("too many subscripts (%d expected)", k
);
2047 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2052 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2053 value of the element of *ARR at the ARITY indices given in
2054 IND. Does not read the entire array into memory. */
2057 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2062 for (k
= 0; k
< arity
; k
+= 1)
2067 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2068 error ("too many subscripts (%d expected)", k
);
2069 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2071 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2072 idx
= value_pos_atr (ind
[k
]);
2074 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2075 arr
= value_add (arr
, idx
);
2076 type
= TYPE_TARGET_TYPE (type
);
2079 return value_ind (arr
);
2082 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2083 actual type of ARRAY_PTR is ignored), returns a reference to
2084 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2085 bound of this array is LOW, as per Ada rules. */
2086 static struct value
*
2087 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2090 CORE_ADDR base
= value_as_address (array_ptr
)
2091 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2092 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2093 struct type
*index_type
=
2094 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2096 struct type
*slice_type
=
2097 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2098 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2102 static struct value
*
2103 ada_value_slice (struct value
*array
, int low
, int high
)
2105 struct type
*type
= VALUE_TYPE (array
);
2106 struct type
*index_type
=
2107 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2108 struct type
*slice_type
=
2109 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2110 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2113 /* If type is a record type in the form of a standard GNAT array
2114 descriptor, returns the number of dimensions for type. If arr is a
2115 simple array, returns the number of "array of"s that prefix its
2116 type designation. Otherwise, returns 0. */
2119 ada_array_arity (struct type
*type
)
2126 type
= desc_base_type (type
);
2129 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2130 return desc_arity (desc_bounds_type (type
));
2132 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2135 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2141 /* If TYPE is a record type in the form of a standard GNAT array
2142 descriptor or a simple array type, returns the element type for
2143 TYPE after indexing by NINDICES indices, or by all indices if
2144 NINDICES is -1. Otherwise, returns NULL. */
2147 ada_array_element_type (struct type
*type
, int nindices
)
2149 type
= desc_base_type (type
);
2151 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2154 struct type
*p_array_type
;
2156 p_array_type
= desc_data_type (type
);
2158 k
= ada_array_arity (type
);
2162 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2163 if (nindices
>= 0 && k
> nindices
)
2165 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2166 while (k
> 0 && p_array_type
!= NULL
)
2168 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2171 return p_array_type
;
2173 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2175 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2177 type
= TYPE_TARGET_TYPE (type
);
2186 /* The type of nth index in arrays of given type (n numbering from 1).
2187 Does not examine memory. */
2190 ada_index_type (struct type
*type
, int n
)
2192 struct type
*result_type
;
2194 type
= desc_base_type (type
);
2196 if (n
> ada_array_arity (type
))
2199 if (ada_is_simple_array_type (type
))
2203 for (i
= 1; i
< n
; i
+= 1)
2204 type
= TYPE_TARGET_TYPE (type
);
2205 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2206 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2207 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2208 perhaps stabsread.c would make more sense. */
2209 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2210 result_type
= builtin_type_int
;
2215 return desc_index_type (desc_bounds_type (type
), n
);
2218 /* Given that arr is an array type, returns the lower bound of the
2219 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2220 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2221 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2222 bounds type. It works for other arrays with bounds supplied by
2223 run-time quantities other than discriminants. */
2226 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2227 struct type
** typep
)
2230 struct type
*index_type_desc
;
2232 if (ada_is_packed_array_type (arr_type
))
2233 arr_type
= decode_packed_array_type (arr_type
);
2235 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2238 *typep
= builtin_type_int
;
2239 return (LONGEST
) - which
;
2242 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2243 type
= TYPE_TARGET_TYPE (arr_type
);
2247 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2248 if (index_type_desc
== NULL
)
2250 struct type
*range_type
;
2251 struct type
*index_type
;
2255 type
= TYPE_TARGET_TYPE (type
);
2259 range_type
= TYPE_INDEX_TYPE (type
);
2260 index_type
= TYPE_TARGET_TYPE (range_type
);
2261 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2262 index_type
= builtin_type_long
;
2264 *typep
= index_type
;
2266 (LONGEST
) (which
== 0
2267 ? TYPE_LOW_BOUND (range_type
)
2268 : TYPE_HIGH_BOUND (range_type
));
2272 struct type
*index_type
=
2273 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2274 NULL
, TYPE_OBJFILE (arr_type
));
2276 *typep
= TYPE_TARGET_TYPE (index_type
);
2278 (LONGEST
) (which
== 0
2279 ? TYPE_LOW_BOUND (index_type
)
2280 : TYPE_HIGH_BOUND (index_type
));
2284 /* Given that arr is an array value, returns the lower bound of the
2285 nth index (numbering from 1) if which is 0, and the upper bound if
2286 which is 1. This routine will also work for arrays with bounds
2287 supplied by run-time quantities other than discriminants. */
2290 ada_array_bound (struct value
*arr
, int n
, int which
)
2292 struct type
*arr_type
= VALUE_TYPE (arr
);
2294 if (ada_is_packed_array_type (arr_type
))
2295 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2296 else if (ada_is_simple_array_type (arr_type
))
2299 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2300 return value_from_longest (type
, v
);
2303 return desc_one_bound (desc_bounds (arr
), n
, which
);
2306 /* Given that arr is an array value, returns the length of the
2307 nth index. This routine will also work for arrays with bounds
2308 supplied by run-time quantities other than discriminants.
2309 Does not work for arrays indexed by enumeration types with representation
2310 clauses at the moment. */
2313 ada_array_length (struct value
*arr
, int n
)
2315 struct type
*arr_type
= ada_check_typedef (VALUE_TYPE (arr
));
2317 if (ada_is_packed_array_type (arr_type
))
2318 return ada_array_length (decode_packed_array (arr
), n
);
2320 if (ada_is_simple_array_type (arr_type
))
2324 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2325 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2326 return value_from_longest (type
, v
);
2330 value_from_longest (builtin_type_int
,
2331 value_as_long (desc_one_bound (desc_bounds (arr
),
2333 - value_as_long (desc_one_bound (desc_bounds (arr
),
2337 /* An empty array whose type is that of ARR_TYPE (an array type),
2338 with bounds LOW to LOW-1. */
2340 static struct value
*
2341 empty_array (struct type
*arr_type
, int low
)
2343 struct type
*index_type
=
2344 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2346 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2347 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2351 /* Name resolution */
2353 /* The "decoded" name for the user-definable Ada operator corresponding
2357 ada_decoded_op_name (enum exp_opcode op
)
2361 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2363 if (ada_opname_table
[i
].op
== op
)
2364 return ada_opname_table
[i
].decoded
;
2366 error ("Could not find operator name for opcode");
2370 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2371 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2372 undefined namespace) and converts operators that are
2373 user-defined into appropriate function calls. If CONTEXT_TYPE is
2374 non-null, it provides a preferred result type [at the moment, only
2375 type void has any effect---causing procedures to be preferred over
2376 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2377 return type is preferred. May change (expand) *EXP. */
2380 resolve (struct expression
**expp
, int void_context_p
)
2384 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2387 /* Resolve the operator of the subexpression beginning at
2388 position *POS of *EXPP. "Resolving" consists of replacing
2389 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2390 with their resolutions, replacing built-in operators with
2391 function calls to user-defined operators, where appropriate, and,
2392 when DEPROCEDURE_P is non-zero, converting function-valued variables
2393 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2394 are as in ada_resolve, above. */
2396 static struct value
*
2397 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2398 struct type
*context_type
)
2402 struct expression
*exp
; /* Convenience: == *expp. */
2403 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2404 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2405 int nargs
; /* Number of operands. */
2411 /* Pass one: resolve operands, saving their types and updating *pos. */
2415 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2416 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2421 resolve_subexp (expp
, pos
, 0, NULL
);
2423 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2428 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2433 resolve_subexp (expp
, pos
, 0, NULL
);
2436 case OP_ATR_MODULUS
:
2466 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2468 resolve_subexp (expp
, pos
, 1, NULL
);
2470 resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2488 case BINOP_LOGICAL_AND
:
2489 case BINOP_LOGICAL_OR
:
2490 case BINOP_BITWISE_AND
:
2491 case BINOP_BITWISE_IOR
:
2492 case BINOP_BITWISE_XOR
:
2495 case BINOP_NOTEQUAL
:
2502 case BINOP_SUBSCRIPT
:
2510 case UNOP_LOGICAL_NOT
:
2527 case OP_INTERNALVAR
:
2536 case STRUCTOP_STRUCT
:
2537 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2543 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2548 case TERNOP_IN_RANGE
:
2553 case BINOP_IN_BOUNDS
:
2559 error ("Unexpected operator during name resolution");
2562 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2563 for (i
= 0; i
< nargs
; i
+= 1)
2564 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2568 /* Pass two: perform any resolution on principal operator. */
2575 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2577 struct ada_symbol_info
*candidates
;
2581 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2582 (exp
->elts
[pc
+ 2].symbol
),
2583 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2586 if (n_candidates
> 1)
2588 /* Types tend to get re-introduced locally, so if there
2589 are any local symbols that are not types, first filter
2592 for (j
= 0; j
< n_candidates
; j
+= 1)
2593 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2599 case LOC_REGPARM_ADDR
:
2603 case LOC_BASEREG_ARG
:
2605 case LOC_COMPUTED_ARG
:
2611 if (j
< n_candidates
)
2614 while (j
< n_candidates
)
2616 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2618 candidates
[j
] = candidates
[n_candidates
- 1];
2627 if (n_candidates
== 0)
2628 error ("No definition found for %s",
2629 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2630 else if (n_candidates
== 1)
2632 else if (deprocedure_p
2633 && !is_nonfunction (candidates
, n_candidates
))
2635 i
= ada_resolve_function
2636 (candidates
, n_candidates
, NULL
, 0,
2637 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2640 error ("Could not find a match for %s",
2641 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2645 printf_filtered ("Multiple matches for %s\n",
2646 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2647 user_select_syms (candidates
, n_candidates
, 1);
2651 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2652 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2653 if (innermost_block
== NULL
2654 || contained_in (candidates
[i
].block
, innermost_block
))
2655 innermost_block
= candidates
[i
].block
;
2659 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2662 replace_operator_with_call (expp
, pc
, 0, 0,
2663 exp
->elts
[pc
+ 2].symbol
,
2664 exp
->elts
[pc
+ 1].block
);
2671 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2672 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2674 struct ada_symbol_info
*candidates
;
2678 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2679 (exp
->elts
[pc
+ 5].symbol
),
2680 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2682 if (n_candidates
== 1)
2686 i
= ada_resolve_function
2687 (candidates
, n_candidates
,
2689 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2692 error ("Could not find a match for %s",
2693 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2696 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2697 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2698 if (innermost_block
== NULL
2699 || contained_in (candidates
[i
].block
, innermost_block
))
2700 innermost_block
= candidates
[i
].block
;
2711 case BINOP_BITWISE_AND
:
2712 case BINOP_BITWISE_IOR
:
2713 case BINOP_BITWISE_XOR
:
2715 case BINOP_NOTEQUAL
:
2723 case UNOP_LOGICAL_NOT
:
2725 if (possible_user_operator_p (op
, argvec
))
2727 struct ada_symbol_info
*candidates
;
2731 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2732 (struct block
*) NULL
, VAR_DOMAIN
,
2734 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2735 ada_decoded_op_name (op
), NULL
);
2739 replace_operator_with_call (expp
, pc
, nargs
, 1,
2740 candidates
[i
].sym
, candidates
[i
].block
);
2750 return evaluate_subexp_type (exp
, pos
);
2753 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2754 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2755 a non-pointer. A type of 'void' (which is never a valid expression type)
2756 by convention matches anything. */
2757 /* The term "match" here is rather loose. The match is heuristic and
2758 liberal. FIXME: TOO liberal, in fact. */
2761 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2763 ftype
= ada_check_typedef (ftype
);
2764 atype
= ada_check_typedef (atype
);
2766 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2767 ftype
= TYPE_TARGET_TYPE (ftype
);
2768 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2769 atype
= TYPE_TARGET_TYPE (atype
);
2771 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2772 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2775 switch (TYPE_CODE (ftype
))
2780 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2781 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2782 TYPE_TARGET_TYPE (atype
), 0);
2785 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2787 case TYPE_CODE_ENUM
:
2788 case TYPE_CODE_RANGE
:
2789 switch (TYPE_CODE (atype
))
2792 case TYPE_CODE_ENUM
:
2793 case TYPE_CODE_RANGE
:
2799 case TYPE_CODE_ARRAY
:
2800 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2801 || ada_is_array_descriptor_type (atype
));
2803 case TYPE_CODE_STRUCT
:
2804 if (ada_is_array_descriptor_type (ftype
))
2805 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2806 || ada_is_array_descriptor_type (atype
));
2808 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2809 && !ada_is_array_descriptor_type (atype
));
2811 case TYPE_CODE_UNION
:
2813 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2817 /* Return non-zero if the formals of FUNC "sufficiently match" the
2818 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2819 may also be an enumeral, in which case it is treated as a 0-
2820 argument function. */
2823 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2826 struct type
*func_type
= SYMBOL_TYPE (func
);
2828 if (SYMBOL_CLASS (func
) == LOC_CONST
2829 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2830 return (n_actuals
== 0);
2831 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2834 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2837 for (i
= 0; i
< n_actuals
; i
+= 1)
2839 if (actuals
[i
] == NULL
)
2843 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2844 struct type
*atype
= ada_check_typedef (VALUE_TYPE (actuals
[i
]));
2846 if (!ada_type_match (ftype
, atype
, 1))
2853 /* False iff function type FUNC_TYPE definitely does not produce a value
2854 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2855 FUNC_TYPE is not a valid function type with a non-null return type
2856 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2859 return_match (struct type
*func_type
, struct type
*context_type
)
2861 struct type
*return_type
;
2863 if (func_type
== NULL
)
2866 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2867 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2869 return_type
= base_type (func_type
);
2870 if (return_type
== NULL
)
2873 context_type
= base_type (context_type
);
2875 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2876 return context_type
== NULL
|| return_type
== context_type
;
2877 else if (context_type
== NULL
)
2878 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2880 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2884 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
2885 function (if any) that matches the types of the NARGS arguments in
2886 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2887 that returns that type, then eliminate matches that don't. If
2888 CONTEXT_TYPE is void and there is at least one match that does not
2889 return void, eliminate all matches that do.
2891 Asks the user if there is more than one match remaining. Returns -1
2892 if there is no such symbol or none is selected. NAME is used
2893 solely for messages. May re-arrange and modify SYMS in
2894 the process; the index returned is for the modified vector. */
2897 ada_resolve_function (struct ada_symbol_info syms
[],
2898 int nsyms
, struct value
**args
, int nargs
,
2899 const char *name
, struct type
*context_type
)
2902 int m
; /* Number of hits */
2903 struct type
*fallback
;
2904 struct type
*return_type
;
2906 return_type
= context_type
;
2907 if (context_type
== NULL
)
2908 fallback
= builtin_type_void
;
2915 for (k
= 0; k
< nsyms
; k
+= 1)
2917 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
2919 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
2920 && return_match (type
, return_type
))
2926 if (m
> 0 || return_type
== fallback
)
2929 return_type
= fallback
;
2936 printf_filtered ("Multiple matches for %s\n", name
);
2937 user_select_syms (syms
, m
, 1);
2943 /* Returns true (non-zero) iff decoded name N0 should appear before N1
2944 in a listing of choices during disambiguation (see sort_choices, below).
2945 The idea is that overloadings of a subprogram name from the
2946 same package should sort in their source order. We settle for ordering
2947 such symbols by their trailing number (__N or $N). */
2950 encoded_ordered_before (char *N0
, char *N1
)
2954 else if (N0
== NULL
)
2959 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2961 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2963 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2964 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2968 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2971 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2973 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
2974 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
2976 return (strcmp (N0
, N1
) < 0);
2980 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
2984 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
2987 for (i
= 1; i
< nsyms
; i
+= 1)
2989 struct ada_symbol_info sym
= syms
[i
];
2992 for (j
= i
- 1; j
>= 0; j
-= 1)
2994 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
2995 SYMBOL_LINKAGE_NAME (sym
.sym
)))
2997 syms
[j
+ 1] = syms
[j
];
3003 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3004 by asking the user (if necessary), returning the number selected,
3005 and setting the first elements of SYMS items. Error if no symbols
3008 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3009 to be re-integrated one of these days. */
3012 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3015 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3017 int first_choice
= (max_results
== 1) ? 1 : 2;
3019 if (max_results
< 1)
3020 error ("Request to select 0 symbols!");
3024 printf_unfiltered ("[0] cancel\n");
3025 if (max_results
> 1)
3026 printf_unfiltered ("[1] all\n");
3028 sort_choices (syms
, nsyms
);
3030 for (i
= 0; i
< nsyms
; i
+= 1)
3032 if (syms
[i
].sym
== NULL
)
3035 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3037 struct symtab_and_line sal
=
3038 find_function_start_sal (syms
[i
].sym
, 1);
3039 printf_unfiltered ("[%d] %s at %s:%d\n", i
+ first_choice
,
3040 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3042 ? "<no source file available>"
3043 : sal
.symtab
->filename
), sal
.line
);
3049 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3050 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3051 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3052 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3054 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3055 printf_unfiltered ("[%d] %s at %s:%d\n",
3057 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3058 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3059 else if (is_enumeral
3060 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3062 printf_unfiltered ("[%d] ", i
+ first_choice
);
3063 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3065 printf_unfiltered ("'(%s) (enumeral)\n",
3066 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3068 else if (symtab
!= NULL
)
3069 printf_unfiltered (is_enumeral
3070 ? "[%d] %s in %s (enumeral)\n"
3071 : "[%d] %s at %s:?\n",
3073 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3076 printf_unfiltered (is_enumeral
3077 ? "[%d] %s (enumeral)\n"
3080 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3084 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3087 for (i
= 0; i
< n_chosen
; i
+= 1)
3088 syms
[i
] = syms
[chosen
[i
]];
3093 /* Read and validate a set of numeric choices from the user in the
3094 range 0 .. N_CHOICES-1. Place the results in increasing
3095 order in CHOICES[0 .. N-1], and return N.
3097 The user types choices as a sequence of numbers on one line
3098 separated by blanks, encoding them as follows:
3100 + A choice of 0 means to cancel the selection, throwing an error.
3101 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3102 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3104 The user is not allowed to choose more than MAX_RESULTS values.
3106 ANNOTATION_SUFFIX, if present, is used to annotate the input
3107 prompts (for use with the -f switch). */
3110 get_selections (int *choices
, int n_choices
, int max_results
,
3111 int is_all_choice
, char *annotation_suffix
)
3116 int first_choice
= is_all_choice
? 2 : 1;
3118 prompt
= getenv ("PS2");
3122 printf_unfiltered ("%s ", prompt
);
3123 gdb_flush (gdb_stdout
);
3125 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3128 error_no_arg ("one or more choice numbers");
3132 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3133 order, as given in args. Choices are validated. */
3139 while (isspace (*args
))
3141 if (*args
== '\0' && n_chosen
== 0)
3142 error_no_arg ("one or more choice numbers");
3143 else if (*args
== '\0')
3146 choice
= strtol (args
, &args2
, 10);
3147 if (args
== args2
|| choice
< 0
3148 || choice
> n_choices
+ first_choice
- 1)
3149 error ("Argument must be choice number");
3153 error ("cancelled");
3155 if (choice
< first_choice
)
3157 n_chosen
= n_choices
;
3158 for (j
= 0; j
< n_choices
; j
+= 1)
3162 choice
-= first_choice
;
3164 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3168 if (j
< 0 || choice
!= choices
[j
])
3171 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3172 choices
[k
+ 1] = choices
[k
];
3173 choices
[j
+ 1] = choice
;
3178 if (n_chosen
> max_results
)
3179 error ("Select no more than %d of the above", max_results
);
3184 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3185 on the function identified by SYM and BLOCK, and taking NARGS
3186 arguments. Update *EXPP as needed to hold more space. */
3189 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3190 int oplen
, struct symbol
*sym
,
3191 struct block
*block
)
3193 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3194 symbol, -oplen for operator being replaced). */
3195 struct expression
*newexp
= (struct expression
*)
3196 xmalloc (sizeof (struct expression
)
3197 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3198 struct expression
*exp
= *expp
;
3200 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3201 newexp
->language_defn
= exp
->language_defn
;
3202 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3203 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3204 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3206 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3207 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3209 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3210 newexp
->elts
[pc
+ 4].block
= block
;
3211 newexp
->elts
[pc
+ 5].symbol
= sym
;
3217 /* Type-class predicates */
3219 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3223 numeric_type_p (struct type
*type
)
3229 switch (TYPE_CODE (type
))
3234 case TYPE_CODE_RANGE
:
3235 return (type
== TYPE_TARGET_TYPE (type
)
3236 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3243 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3246 integer_type_p (struct type
*type
)
3252 switch (TYPE_CODE (type
))
3256 case TYPE_CODE_RANGE
:
3257 return (type
== TYPE_TARGET_TYPE (type
)
3258 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3265 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3268 scalar_type_p (struct type
*type
)
3274 switch (TYPE_CODE (type
))
3277 case TYPE_CODE_RANGE
:
3278 case TYPE_CODE_ENUM
:
3287 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3290 discrete_type_p (struct type
*type
)
3296 switch (TYPE_CODE (type
))
3299 case TYPE_CODE_RANGE
:
3300 case TYPE_CODE_ENUM
:
3308 /* Returns non-zero if OP with operands in the vector ARGS could be
3309 a user-defined function. Errs on the side of pre-defined operators
3310 (i.e., result 0). */
3313 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3315 struct type
*type0
=
3316 (args
[0] == NULL
) ? NULL
: ada_check_typedef (VALUE_TYPE (args
[0]));
3317 struct type
*type1
=
3318 (args
[1] == NULL
) ? NULL
: ada_check_typedef (VALUE_TYPE (args
[1]));
3332 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3336 case BINOP_BITWISE_AND
:
3337 case BINOP_BITWISE_IOR
:
3338 case BINOP_BITWISE_XOR
:
3339 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3342 case BINOP_NOTEQUAL
:
3347 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3351 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3352 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3353 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3354 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3355 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3356 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
))
3357 != TYPE_CODE_ARRAY
))));
3360 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3364 case UNOP_LOGICAL_NOT
:
3366 return (!numeric_type_p (type0
));
3373 /* NOTE: In the following, we assume that a renaming type's name may
3374 have an ___XD suffix. It would be nice if this went away at some
3377 /* If TYPE encodes a renaming, returns the renaming suffix, which
3378 is XR for an object renaming, XRP for a procedure renaming, XRE for
3379 an exception renaming, and XRS for a subprogram renaming. Returns
3380 NULL if NAME encodes none of these. */
3383 ada_renaming_type (struct type
*type
)
3385 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3387 const char *name
= type_name_no_tag (type
);
3388 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3390 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3399 /* Return non-zero iff SYM encodes an object renaming. */
3402 ada_is_object_renaming (struct symbol
*sym
)
3404 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3405 return renaming_type
!= NULL
3406 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3409 /* Assuming that SYM encodes a non-object renaming, returns the original
3410 name of the renamed entity. The name is good until the end of
3414 ada_simple_renamed_entity (struct symbol
*sym
)
3417 const char *raw_name
;
3421 type
= SYMBOL_TYPE (sym
);
3422 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3423 error ("Improperly encoded renaming.");
3425 raw_name
= TYPE_FIELD_NAME (type
, 0);
3426 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3428 error ("Improperly encoded renaming.");
3430 result
= xmalloc (len
+ 1);
3431 strncpy (result
, raw_name
, len
);
3432 result
[len
] = '\000';
3437 /* Evaluation: Function Calls */
3439 /* Return an lvalue containing the value VAL. This is the identity on
3440 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3441 on the stack, using and updating *SP as the stack pointer, and
3442 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3444 static struct value
*
3445 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3447 if (! VALUE_LVAL (val
))
3449 int len
= TYPE_LENGTH (ada_check_typedef (VALUE_TYPE (val
)));
3451 /* The following is taken from the structure-return code in
3452 call_function_by_hand. FIXME: Therefore, some refactoring seems
3454 if (INNER_THAN (1, 2))
3456 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3457 reserving sufficient space. */
3459 if (gdbarch_frame_align_p (current_gdbarch
))
3460 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3461 VALUE_ADDRESS (val
) = *sp
;
3465 /* Stack grows upward. Align the frame, allocate space, and
3466 then again, re-align the frame. */
3467 if (gdbarch_frame_align_p (current_gdbarch
))
3468 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3469 VALUE_ADDRESS (val
) = *sp
;
3471 if (gdbarch_frame_align_p (current_gdbarch
))
3472 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3475 write_memory (VALUE_ADDRESS (val
), VALUE_CONTENTS_RAW (val
), len
);
3481 /* Return the value ACTUAL, converted to be an appropriate value for a
3482 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3483 allocating any necessary descriptors (fat pointers), or copies of
3484 values not residing in memory, updating it as needed. */
3486 static struct value
*
3487 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3490 struct type
*actual_type
= ada_check_typedef (VALUE_TYPE (actual
));
3491 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3492 struct type
*formal_target
=
3493 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3494 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3495 struct type
*actual_target
=
3496 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3497 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3499 if (ada_is_array_descriptor_type (formal_target
)
3500 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3501 return make_array_descriptor (formal_type
, actual
, sp
);
3502 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3504 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3505 && ada_is_array_descriptor_type (actual_target
))
3506 return desc_data (actual
);
3507 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3509 if (VALUE_LVAL (actual
) != lval_memory
)
3512 actual_type
= ada_check_typedef (VALUE_TYPE (actual
));
3513 val
= allocate_value (actual_type
);
3514 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3515 (char *) VALUE_CONTENTS (actual
),
3516 TYPE_LENGTH (actual_type
));
3517 actual
= ensure_lval (val
, sp
);
3519 return value_addr (actual
);
3522 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3523 return ada_value_ind (actual
);
3529 /* Push a descriptor of type TYPE for array value ARR on the stack at
3530 *SP, updating *SP to reflect the new descriptor. Return either
3531 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3532 to-descriptor type rather than a descriptor type), a struct value *
3533 representing a pointer to this descriptor. */
3535 static struct value
*
3536 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3538 struct type
*bounds_type
= desc_bounds_type (type
);
3539 struct type
*desc_type
= desc_base_type (type
);
3540 struct value
*descriptor
= allocate_value (desc_type
);
3541 struct value
*bounds
= allocate_value (bounds_type
);
3544 for (i
= ada_array_arity (ada_check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3546 modify_general_field (VALUE_CONTENTS (bounds
),
3547 value_as_long (ada_array_bound (arr
, i
, 0)),
3548 desc_bound_bitpos (bounds_type
, i
, 0),
3549 desc_bound_bitsize (bounds_type
, i
, 0));
3550 modify_general_field (VALUE_CONTENTS (bounds
),
3551 value_as_long (ada_array_bound (arr
, i
, 1)),
3552 desc_bound_bitpos (bounds_type
, i
, 1),
3553 desc_bound_bitsize (bounds_type
, i
, 1));
3556 bounds
= ensure_lval (bounds
, sp
);
3558 modify_general_field (VALUE_CONTENTS (descriptor
),
3559 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3560 fat_pntr_data_bitpos (desc_type
),
3561 fat_pntr_data_bitsize (desc_type
));
3563 modify_general_field (VALUE_CONTENTS (descriptor
),
3564 VALUE_ADDRESS (bounds
),
3565 fat_pntr_bounds_bitpos (desc_type
),
3566 fat_pntr_bounds_bitsize (desc_type
));
3568 descriptor
= ensure_lval (descriptor
, sp
);
3570 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3571 return value_addr (descriptor
);
3577 /* Assuming a dummy frame has been established on the target, perform any
3578 conversions needed for calling function FUNC on the NARGS actual
3579 parameters in ARGS, other than standard C conversions. Does
3580 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3581 does not match the number of arguments expected. Use *SP as a
3582 stack pointer for additional data that must be pushed, updating its
3586 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3591 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3592 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3595 for (i
= 0; i
< nargs
; i
+= 1)
3597 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3600 /* Dummy definitions for an experimental caching module that is not
3601 * used in the public sources. */
3604 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3605 struct symbol
**sym
, struct block
**block
,
3606 struct symtab
**symtab
)
3612 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3613 struct block
*block
, struct symtab
*symtab
)
3619 /* Return the result of a standard (literal, C-like) lookup of NAME in
3620 given DOMAIN, visible from lexical block BLOCK. */
3622 static struct symbol
*
3623 standard_lookup (const char *name
, const struct block
*block
,
3627 struct symtab
*symtab
;
3629 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3632 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3633 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3638 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3639 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3640 since they contend in overloading in the same way. */
3642 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3646 for (i
= 0; i
< n
; i
+= 1)
3647 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3648 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3649 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3655 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3656 struct types. Otherwise, they may not. */
3659 equiv_types (struct type
*type0
, struct type
*type1
)
3663 if (type0
== NULL
|| type1
== NULL
3664 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3666 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3667 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3668 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3669 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3675 /* True iff SYM0 represents the same entity as SYM1, or one that is
3676 no more defined than that of SYM1. */
3679 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3683 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3684 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3687 switch (SYMBOL_CLASS (sym0
))
3693 struct type
*type0
= SYMBOL_TYPE (sym0
);
3694 struct type
*type1
= SYMBOL_TYPE (sym1
);
3695 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3696 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3697 int len0
= strlen (name0
);
3699 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3700 && (equiv_types (type0
, type1
)
3701 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3702 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3705 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3706 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3712 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3713 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3716 add_defn_to_vec (struct obstack
*obstackp
,
3718 struct block
*block
, struct symtab
*symtab
)
3722 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3724 if (SYMBOL_TYPE (sym
) != NULL
)
3725 SYMBOL_TYPE (sym
) = ada_check_typedef (SYMBOL_TYPE (sym
));
3726 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3728 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3730 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3732 prevDefns
[i
].sym
= sym
;
3733 prevDefns
[i
].block
= block
;
3734 prevDefns
[i
].symtab
= symtab
;
3740 struct ada_symbol_info info
;
3744 info
.symtab
= symtab
;
3745 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3749 /* Number of ada_symbol_info structures currently collected in
3750 current vector in *OBSTACKP. */
3753 num_defns_collected (struct obstack
*obstackp
)
3755 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3758 /* Vector of ada_symbol_info structures currently collected in current
3759 vector in *OBSTACKP. If FINISH, close off the vector and return
3760 its final address. */
3762 static struct ada_symbol_info
*
3763 defns_collected (struct obstack
*obstackp
, int finish
)
3766 return obstack_finish (obstackp
);
3768 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3771 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3772 Check the global symbols if GLOBAL, the static symbols if not.
3773 Do wild-card match if WILD. */
3775 static struct partial_symbol
*
3776 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3777 int global
, domain_enum
namespace, int wild
)
3779 struct partial_symbol
**start
;
3780 int name_len
= strlen (name
);
3781 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3790 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3791 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3795 for (i
= 0; i
< length
; i
+= 1)
3797 struct partial_symbol
*psym
= start
[i
];
3799 if (SYMBOL_DOMAIN (psym
) == namespace
3800 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3814 int M
= (U
+ i
) >> 1;
3815 struct partial_symbol
*psym
= start
[M
];
3816 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3818 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3820 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
3831 struct partial_symbol
*psym
= start
[i
];
3833 if (SYMBOL_DOMAIN (psym
) == namespace)
3835 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
3843 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3857 int M
= (U
+ i
) >> 1;
3858 struct partial_symbol
*psym
= start
[M
];
3859 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
3861 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
3863 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
3874 struct partial_symbol
*psym
= start
[i
];
3876 if (SYMBOL_DOMAIN (psym
) == namespace)
3880 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
3883 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
3885 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
3895 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3905 /* Find a symbol table containing symbol SYM or NULL if none. */
3907 static struct symtab
*
3908 symtab_for_sym (struct symbol
*sym
)
3911 struct objfile
*objfile
;
3913 struct symbol
*tmp_sym
;
3914 struct dict_iterator iter
;
3917 ALL_SYMTABS (objfile
, s
)
3919 switch (SYMBOL_CLASS (sym
))
3927 case LOC_CONST_BYTES
:
3928 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3929 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3931 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3932 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3938 switch (SYMBOL_CLASS (sym
))
3944 case LOC_REGPARM_ADDR
:
3949 case LOC_BASEREG_ARG
:
3951 case LOC_COMPUTED_ARG
:
3952 for (j
= FIRST_LOCAL_BLOCK
;
3953 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3955 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3956 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3967 /* Return a minimal symbol matching NAME according to Ada decoding
3968 rules. Returns NULL if there is no such minimal symbol. Names
3969 prefixed with "standard__" are handled specially: "standard__" is
3970 first stripped off, and only static and global symbols are searched. */
3972 struct minimal_symbol
*
3973 ada_lookup_simple_minsym (const char *name
)
3975 struct objfile
*objfile
;
3976 struct minimal_symbol
*msymbol
;
3979 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
3981 name
+= sizeof ("standard__") - 1;
3985 wild_match
= (strstr (name
, "__") == NULL
);
3987 ALL_MSYMBOLS (objfile
, msymbol
)
3989 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
3990 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
3997 /* For all subprograms that statically enclose the subprogram of the
3998 selected frame, add symbols matching identifier NAME in DOMAIN
3999 and their blocks to the list of data in OBSTACKP, as for
4000 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4004 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4005 const char *name
, domain_enum
namespace,
4010 /* FIXME: The next two routines belong in symtab.c */
4013 restore_language (void *lang
)
4015 set_language ((enum language
) lang
);
4018 /* As for lookup_symbol, but performed as if the current language
4022 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4023 domain_enum domain
, enum language lang
,
4024 int *is_a_field_of_this
, struct symtab
**symtab
)
4026 struct cleanup
*old_chain
4027 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4028 struct symbol
*result
;
4029 set_language (lang
);
4030 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4031 do_cleanups (old_chain
);
4035 /* True if TYPE is definitely an artificial type supplied to a symbol
4036 for which no debugging information was given in the symbol file. */
4039 is_nondebugging_type (struct type
*type
)
4041 char *name
= ada_type_name (type
);
4042 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4045 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4046 duplicate other symbols in the list (The only case I know of where
4047 this happens is when object files containing stabs-in-ecoff are
4048 linked with files containing ordinary ecoff debugging symbols (or no
4049 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4050 Returns the number of items in the modified list. */
4053 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4060 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4061 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4062 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4064 for (j
= 0; j
< nsyms
; j
+= 1)
4067 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4068 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4069 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4070 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4071 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4072 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4075 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4076 syms
[k
- 1] = syms
[k
];
4089 /* Given a type that corresponds to a renaming entity, use the type name
4090 to extract the scope (package name or function name, fully qualified,
4091 and following the GNAT encoding convention) where this renaming has been
4092 defined. The string returned needs to be deallocated after use. */
4095 xget_renaming_scope (struct type
*renaming_type
)
4097 /* The renaming types adhere to the following convention:
4098 <scope>__<rename>___<XR extension>.
4099 So, to extract the scope, we search for the "___XR" extension,
4100 and then backtrack until we find the first "__". */
4102 const char *name
= type_name_no_tag (renaming_type
);
4103 char *suffix
= strstr (name
, "___XR");
4108 /* Now, backtrack a bit until we find the first "__". Start looking
4109 at suffix - 3, as the <rename> part is at least one character long. */
4111 for (last
= suffix
- 3; last
> name
; last
--)
4112 if (last
[0] == '_' && last
[1] == '_')
4115 /* Make a copy of scope and return it. */
4117 scope_len
= last
- name
;
4118 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4120 strncpy (scope
, name
, scope_len
);
4121 scope
[scope_len
] = '\0';
4126 /* Return nonzero if NAME corresponds to a package name. */
4129 is_package_name (const char *name
)
4131 /* Here, We take advantage of the fact that no symbols are generated
4132 for packages, while symbols are generated for each function.
4133 So the condition for NAME represent a package becomes equivalent
4134 to NAME not existing in our list of symbols. There is only one
4135 small complication with library-level functions (see below). */
4139 /* If it is a function that has not been defined at library level,
4140 then we should be able to look it up in the symbols. */
4141 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4144 /* Library-level function names start with "_ada_". See if function
4145 "_ada_" followed by NAME can be found. */
4147 /* Do a quick check that NAME does not contain "__", since library-level
4148 functions names can not contain "__" in them. */
4149 if (strstr (name
, "__") != NULL
)
4152 fun_name
= xstrprintf ("_ada_%s", name
);
4154 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4157 /* Return nonzero if SYM corresponds to a renaming entity that is
4158 visible from FUNCTION_NAME. */
4161 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4163 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4165 make_cleanup (xfree
, scope
);
4167 /* If the rename has been defined in a package, then it is visible. */
4168 if (is_package_name (scope
))
4171 /* Check that the rename is in the current function scope by checking
4172 that its name starts with SCOPE. */
4174 /* If the function name starts with "_ada_", it means that it is
4175 a library-level function. Strip this prefix before doing the
4176 comparison, as the encoding for the renaming does not contain
4178 if (strncmp (function_name
, "_ada_", 5) == 0)
4181 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4184 /* Iterates over the SYMS list and remove any entry that corresponds to
4185 a renaming entity that is not visible from the function associated
4189 GNAT emits a type following a specified encoding for each renaming
4190 entity. Unfortunately, STABS currently does not support the definition
4191 of types that are local to a given lexical block, so all renamings types
4192 are emitted at library level. As a consequence, if an application
4193 contains two renaming entities using the same name, and a user tries to
4194 print the value of one of these entities, the result of the ada symbol
4195 lookup will also contain the wrong renaming type.
4197 This function partially covers for this limitation by attempting to
4198 remove from the SYMS list renaming symbols that should be visible
4199 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4200 method with the current information available. The implementation
4201 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4203 - When the user tries to print a rename in a function while there
4204 is another rename entity defined in a package: Normally, the
4205 rename in the function has precedence over the rename in the
4206 package, so the latter should be removed from the list. This is
4207 currently not the case.
4209 - This function will incorrectly remove valid renames if
4210 the CURRENT_BLOCK corresponds to a function which symbol name
4211 has been changed by an "Export" pragma. As a consequence,
4212 the user will be unable to print such rename entities. */
4215 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4216 int nsyms
, struct block
*current_block
)
4218 struct symbol
*current_function
;
4219 char *current_function_name
;
4222 /* Extract the function name associated to CURRENT_BLOCK.
4223 Abort if unable to do so. */
4225 if (current_block
== NULL
)
4228 current_function
= block_function (current_block
);
4229 if (current_function
== NULL
)
4232 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4233 if (current_function_name
== NULL
)
4236 /* Check each of the symbols, and remove it from the list if it is
4237 a type corresponding to a renaming that is out of the scope of
4238 the current block. */
4243 if (ada_is_object_renaming (syms
[i
].sym
)
4244 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4247 for (j
= i
+ 1; j
< nsyms
; j
++)
4248 syms
[j
- 1] = syms
[j
];
4258 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4259 scope and in global scopes, returning the number of matches. Sets
4260 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4261 indicating the symbols found and the blocks and symbol tables (if
4262 any) in which they were found. This vector are transient---good only to
4263 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4264 symbol match within the nest of blocks whose innermost member is BLOCK0,
4265 is the one match returned (no other matches in that or
4266 enclosing blocks is returned). If there are any matches in or
4267 surrounding BLOCK0, then these alone are returned. Otherwise, the
4268 search extends to global and file-scope (static) symbol tables.
4269 Names prefixed with "standard__" are handled specially: "standard__"
4270 is first stripped off, and only static and global symbols are searched. */
4273 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4274 domain_enum
namespace,
4275 struct ada_symbol_info
**results
)
4279 struct partial_symtab
*ps
;
4280 struct blockvector
*bv
;
4281 struct objfile
*objfile
;
4282 struct block
*block
;
4284 struct minimal_symbol
*msymbol
;
4290 obstack_free (&symbol_list_obstack
, NULL
);
4291 obstack_init (&symbol_list_obstack
);
4295 /* Search specified block and its superiors. */
4297 wild_match
= (strstr (name0
, "__") == NULL
);
4299 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4300 needed, but adding const will
4301 have a cascade effect. */
4302 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4306 name
= name0
+ sizeof ("standard__") - 1;
4310 while (block
!= NULL
)
4313 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4314 namespace, NULL
, NULL
, wild_match
);
4316 /* If we found a non-function match, assume that's the one. */
4317 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4318 num_defns_collected (&symbol_list_obstack
)))
4321 block
= BLOCK_SUPERBLOCK (block
);
4324 /* If no luck so far, try to find NAME as a local symbol in some lexically
4325 enclosing subprogram. */
4326 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4327 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4328 name
, namespace, wild_match
);
4330 /* If we found ANY matches among non-global symbols, we're done. */
4332 if (num_defns_collected (&symbol_list_obstack
) > 0)
4336 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4339 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4343 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4344 tables, and psymtab's. */
4346 ALL_SYMTABS (objfile
, s
)
4351 bv
= BLOCKVECTOR (s
);
4352 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4353 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4354 objfile
, s
, wild_match
);
4357 if (namespace == VAR_DOMAIN
)
4359 ALL_MSYMBOLS (objfile
, msymbol
)
4361 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4363 switch (MSYMBOL_TYPE (msymbol
))
4365 case mst_solib_trampoline
:
4368 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4371 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4373 bv
= BLOCKVECTOR (s
);
4374 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4375 ada_add_block_symbols (&symbol_list_obstack
, block
,
4376 SYMBOL_LINKAGE_NAME (msymbol
),
4377 namespace, objfile
, s
, wild_match
);
4379 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4381 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4382 ada_add_block_symbols (&symbol_list_obstack
, block
,
4383 SYMBOL_LINKAGE_NAME (msymbol
),
4384 namespace, objfile
, s
,
4393 ALL_PSYMTABS (objfile
, ps
)
4397 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4399 s
= PSYMTAB_TO_SYMTAB (ps
);
4402 bv
= BLOCKVECTOR (s
);
4403 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4404 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4405 namespace, objfile
, s
, wild_match
);
4409 /* Now add symbols from all per-file blocks if we've gotten no hits
4410 (Not strictly correct, but perhaps better than an error).
4411 Do the symtabs first, then check the psymtabs. */
4413 if (num_defns_collected (&symbol_list_obstack
) == 0)
4416 ALL_SYMTABS (objfile
, s
)
4421 bv
= BLOCKVECTOR (s
);
4422 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4423 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4424 objfile
, s
, wild_match
);
4427 ALL_PSYMTABS (objfile
, ps
)
4431 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4433 s
= PSYMTAB_TO_SYMTAB (ps
);
4434 bv
= BLOCKVECTOR (s
);
4437 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4438 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4439 namespace, objfile
, s
, wild_match
);
4445 ndefns
= num_defns_collected (&symbol_list_obstack
);
4446 *results
= defns_collected (&symbol_list_obstack
, 1);
4448 ndefns
= remove_extra_symbols (*results
, ndefns
);
4451 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4453 if (ndefns
== 1 && cacheIfUnique
)
4454 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4455 (*results
)[0].symtab
);
4457 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4458 (struct block
*) block0
);
4463 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4464 scope and in global scopes, or NULL if none. NAME is folded and
4465 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4466 but is disambiguated by user query if needed. *IS_A_FIELD_OF_THIS is
4467 set to 0 and *SYMTAB is set to the symbol table in which the symbol
4468 was found (in both cases, these assignments occur only if the
4469 pointers are non-null). */
4471 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4472 domain_enum
namespace, int *is_a_field_of_this
,
4473 struct symtab
**symtab
)
4475 struct ada_symbol_info
*candidates
;
4478 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4479 block0
, namespace, &candidates
);
4481 if (n_candidates
== 0)
4484 if (is_a_field_of_this
!= NULL
)
4485 *is_a_field_of_this
= 0;
4489 *symtab
= candidates
[0].symtab
;
4490 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4492 struct objfile
*objfile
;
4495 struct blockvector
*bv
;
4497 /* Search the list of symtabs for one which contains the
4498 address of the start of this block. */
4499 ALL_SYMTABS (objfile
, s
)
4501 bv
= BLOCKVECTOR (s
);
4502 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4503 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4504 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4507 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4509 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4513 return candidates
[0].sym
;
4516 static struct symbol
*
4517 ada_lookup_symbol_nonlocal (const char *name
,
4518 const char *linkage_name
,
4519 const struct block
*block
,
4520 const domain_enum domain
, struct symtab
**symtab
)
4522 if (linkage_name
== NULL
)
4523 linkage_name
= name
;
4524 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4529 /* True iff STR is a possible encoded suffix of a normal Ada name
4530 that is to be ignored for matching purposes. Suffixes of parallel
4531 names (e.g., XVE) are not included here. Currently, the possible suffixes
4532 are given by either of the regular expression:
4534 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4536 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4537 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4541 is_name_suffix (const char *str
)
4544 const char *matching
;
4545 const int len
= strlen (str
);
4547 /* (__[0-9]+)?\.[0-9]+ */
4549 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4552 while (isdigit (matching
[0]))
4554 if (matching
[0] == '\0')
4558 if (matching
[0] == '.')
4561 while (isdigit (matching
[0]))
4563 if (matching
[0] == '\0')
4568 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4571 while (isdigit (matching
[0]))
4573 if (matching
[0] == '\0')
4577 /* ??? We should not modify STR directly, as we are doing below. This
4578 is fine in this case, but may become problematic later if we find
4579 that this alternative did not work, and want to try matching
4580 another one from the begining of STR. Since we modified it, we
4581 won't be able to find the begining of the string anymore! */
4585 while (str
[0] != '_' && str
[0] != '\0')
4587 if (str
[0] != 'n' && str
[0] != 'b')
4592 if (str
[0] == '\000')
4596 if (str
[1] != '_' || str
[2] == '\000')
4600 if (strcmp (str
+ 3, "JM") == 0)
4602 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4603 the LJM suffix in favor of the JM one. But we will
4604 still accept LJM as a valid suffix for a reasonable
4605 amount of time, just to allow ourselves to debug programs
4606 compiled using an older version of GNAT. */
4607 if (strcmp (str
+ 3, "LJM") == 0)
4611 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4612 || str
[4] == 'U' || str
[4] == 'P')
4614 if (str
[4] == 'R' && str
[5] != 'T')
4618 if (!isdigit (str
[2]))
4620 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4621 if (!isdigit (str
[k
]) && str
[k
] != '_')
4625 if (str
[0] == '$' && isdigit (str
[1]))
4627 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4628 if (!isdigit (str
[k
]) && str
[k
] != '_')
4635 /* Return nonzero if the given string starts with a dot ('.')
4636 followed by zero or more digits.
4638 Note: brobecker/2003-11-10: A forward declaration has not been
4639 added at the begining of this file yet, because this function
4640 is only used to work around a problem found during wild matching
4641 when trying to match minimal symbol names against symbol names
4642 obtained from dwarf-2 data. This function is therefore currently
4643 only used in wild_match() and is likely to be deleted when the
4644 problem in dwarf-2 is fixed. */
4647 is_dot_digits_suffix (const char *str
)
4653 while (isdigit (str
[0]))
4655 return (str
[0] == '\0');
4658 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4659 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4660 informational suffixes of NAME (i.e., for which is_name_suffix is
4664 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4670 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4671 stored in the symbol table for nested function names is sometimes
4672 different from the name of the associated entity stored in
4673 the dwarf-2 data: This is the case for nested subprograms, where
4674 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4675 while the symbol name from the dwarf-2 data does not.
4677 Although the DWARF-2 standard documents that entity names stored
4678 in the dwarf-2 data should be identical to the name as seen in
4679 the source code, GNAT takes a different approach as we already use
4680 a special encoding mechanism to convey the information so that
4681 a C debugger can still use the information generated to debug
4682 Ada programs. A corollary is that the symbol names in the dwarf-2
4683 data should match the names found in the symbol table. I therefore
4684 consider this issue as a compiler defect.
4686 Until the compiler is properly fixed, we work-around the problem
4687 by ignoring such suffixes during the match. We do so by making
4688 a copy of PATN0 and NAME0, and then by stripping such a suffix
4689 if present. We then perform the match on the resulting strings. */
4692 name_len
= strlen (name0
);
4694 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4695 strcpy (name
, name0
);
4696 dot
= strrchr (name
, '.');
4697 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4700 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4701 strncpy (patn
, patn0
, patn_len
);
4702 patn
[patn_len
] = '\0';
4703 dot
= strrchr (patn
, '.');
4704 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4707 patn_len
= dot
- patn
;
4711 /* Now perform the wild match. */
4713 name_len
= strlen (name
);
4714 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4715 && strncmp (patn
, name
+ 5, patn_len
) == 0
4716 && is_name_suffix (name
+ patn_len
+ 5))
4719 while (name_len
>= patn_len
)
4721 if (strncmp (patn
, name
, patn_len
) == 0
4722 && is_name_suffix (name
+ patn_len
))
4730 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4735 if (!islower (name
[2]))
4742 if (!islower (name
[1]))
4753 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4754 vector *defn_symbols, updating the list of symbols in OBSTACKP
4755 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4756 OBJFILE is the section containing BLOCK.
4757 SYMTAB is recorded with each symbol added. */
4760 ada_add_block_symbols (struct obstack
*obstackp
,
4761 struct block
*block
, const char *name
,
4762 domain_enum domain
, struct objfile
*objfile
,
4763 struct symtab
*symtab
, int wild
)
4765 struct dict_iterator iter
;
4766 int name_len
= strlen (name
);
4767 /* A matching argument symbol, if any. */
4768 struct symbol
*arg_sym
;
4769 /* Set true when we find a matching non-argument symbol. */
4778 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4780 if (SYMBOL_DOMAIN (sym
) == domain
4781 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
4783 switch (SYMBOL_CLASS (sym
))
4789 case LOC_REGPARM_ADDR
:
4790 case LOC_BASEREG_ARG
:
4791 case LOC_COMPUTED_ARG
:
4794 case LOC_UNRESOLVED
:
4798 add_defn_to_vec (obstackp
,
4799 fixup_symbol_section (sym
, objfile
),
4808 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4810 if (SYMBOL_DOMAIN (sym
) == domain
)
4812 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
4814 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
4816 switch (SYMBOL_CLASS (sym
))
4822 case LOC_REGPARM_ADDR
:
4823 case LOC_BASEREG_ARG
:
4824 case LOC_COMPUTED_ARG
:
4827 case LOC_UNRESOLVED
:
4831 add_defn_to_vec (obstackp
,
4832 fixup_symbol_section (sym
, objfile
),
4841 if (!found_sym
&& arg_sym
!= NULL
)
4843 add_defn_to_vec (obstackp
,
4844 fixup_symbol_section (arg_sym
, objfile
),
4853 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4855 if (SYMBOL_DOMAIN (sym
) == domain
)
4859 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
4862 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
4864 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
4869 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
4871 switch (SYMBOL_CLASS (sym
))
4877 case LOC_REGPARM_ADDR
:
4878 case LOC_BASEREG_ARG
:
4879 case LOC_COMPUTED_ARG
:
4882 case LOC_UNRESOLVED
:
4886 add_defn_to_vec (obstackp
,
4887 fixup_symbol_section (sym
, objfile
),
4895 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4896 They aren't parameters, right? */
4897 if (!found_sym
&& arg_sym
!= NULL
)
4899 add_defn_to_vec (obstackp
,
4900 fixup_symbol_section (arg_sym
, objfile
),
4908 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
4909 to be invisible to users. */
4912 ada_is_ignored_field (struct type
*type
, int field_num
)
4914 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
4918 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
4919 return (name
== NULL
4920 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
4924 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
4925 pointer or reference type whose ultimate target has a tag field. */
4928 ada_is_tagged_type (struct type
*type
, int refok
)
4930 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
4933 /* True iff TYPE represents the type of X'Tag */
4936 ada_is_tag_type (struct type
*type
)
4938 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
4942 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
4943 return (name
!= NULL
4944 && strcmp (name
, "ada__tags__dispatch_table") == 0);
4948 /* The type of the tag on VAL. */
4951 ada_tag_type (struct value
*val
)
4953 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 1, 0, NULL
);
4956 /* The value of the tag on VAL. */
4959 ada_value_tag (struct value
*val
)
4961 return ada_value_struct_elt (val
, "_tag", "record");
4964 /* The value of the tag on the object of type TYPE whose contents are
4965 saved at VALADDR, if it is non-null, or is at memory address
4968 static struct value
*
4969 value_tag_from_contents_and_address (struct type
*type
, char *valaddr
,
4972 int tag_byte_offset
, dummy1
, dummy2
;
4973 struct type
*tag_type
;
4974 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
4977 char *valaddr1
= (valaddr
== NULL
) ? NULL
: valaddr
+ tag_byte_offset
;
4978 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
4980 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
4985 static struct type
*
4986 type_from_tag (struct value
*tag
)
4988 const char *type_name
= ada_tag_name (tag
);
4989 if (type_name
!= NULL
)
4990 return ada_find_any_type (ada_encode (type_name
));
5000 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5001 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5002 The value stored in ARGS->name is valid until the next call to
5006 ada_tag_name_1 (void *args0
)
5008 struct tag_args
*args
= (struct tag_args
*) args0
;
5009 static char name
[1024];
5013 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
5016 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
5019 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5020 for (p
= name
; *p
!= '\0'; p
+= 1)
5027 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5031 ada_tag_name (struct value
*tag
)
5033 struct tag_args args
;
5034 if (!ada_is_tag_type (VALUE_TYPE (tag
)))
5038 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5042 /* The parent type of TYPE, or NULL if none. */
5045 ada_parent_type (struct type
*type
)
5049 type
= ada_check_typedef (type
);
5051 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5054 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5055 if (ada_is_parent_field (type
, i
))
5056 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5061 /* True iff field number FIELD_NUM of structure type TYPE contains the
5062 parent-type (inherited) fields of a derived type. Assumes TYPE is
5063 a structure type with at least FIELD_NUM+1 fields. */
5066 ada_is_parent_field (struct type
*type
, int field_num
)
5068 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5069 return (name
!= NULL
5070 && (strncmp (name
, "PARENT", 6) == 0
5071 || strncmp (name
, "_parent", 7) == 0));
5074 /* True iff field number FIELD_NUM of structure type TYPE is a
5075 transparent wrapper field (which should be silently traversed when doing
5076 field selection and flattened when printing). Assumes TYPE is a
5077 structure type with at least FIELD_NUM+1 fields. Such fields are always
5081 ada_is_wrapper_field (struct type
*type
, int field_num
)
5083 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5084 return (name
!= NULL
5085 && (strncmp (name
, "PARENT", 6) == 0
5086 || strcmp (name
, "REP") == 0
5087 || strncmp (name
, "_parent", 7) == 0
5088 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5091 /* True iff field number FIELD_NUM of structure or union type TYPE
5092 is a variant wrapper. Assumes TYPE is a structure type with at least
5093 FIELD_NUM+1 fields. */
5096 ada_is_variant_part (struct type
*type
, int field_num
)
5098 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5099 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5100 || (is_dynamic_field (type
, field_num
)
5101 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5102 == TYPE_CODE_UNION
)));
5105 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5106 whose discriminants are contained in the record type OUTER_TYPE,
5107 returns the type of the controlling discriminant for the variant. */
5110 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5112 char *name
= ada_variant_discrim_name (var_type
);
5114 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5116 return builtin_type_int
;
5121 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5122 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5123 represents a 'when others' clause; otherwise 0. */
5126 ada_is_others_clause (struct type
*type
, int field_num
)
5128 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5129 return (name
!= NULL
&& name
[0] == 'O');
5132 /* Assuming that TYPE0 is the type of the variant part of a record,
5133 returns the name of the discriminant controlling the variant.
5134 The value is valid until the next call to ada_variant_discrim_name. */
5137 ada_variant_discrim_name (struct type
*type0
)
5139 static char *result
= NULL
;
5140 static size_t result_len
= 0;
5143 const char *discrim_end
;
5144 const char *discrim_start
;
5146 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5147 type
= TYPE_TARGET_TYPE (type0
);
5151 name
= ada_type_name (type
);
5153 if (name
== NULL
|| name
[0] == '\000')
5156 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5159 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5162 if (discrim_end
== name
)
5165 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5168 if (discrim_start
== name
+ 1)
5170 if ((discrim_start
> name
+ 3
5171 && strncmp (discrim_start
- 3, "___", 3) == 0)
5172 || discrim_start
[-1] == '.')
5176 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5177 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5178 result
[discrim_end
- discrim_start
] = '\0';
5182 /* Scan STR for a subtype-encoded number, beginning at position K.
5183 Put the position of the character just past the number scanned in
5184 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5185 Return 1 if there was a valid number at the given position, and 0
5186 otherwise. A "subtype-encoded" number consists of the absolute value
5187 in decimal, followed by the letter 'm' to indicate a negative number.
5188 Assumes 0m does not occur. */
5191 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5195 if (!isdigit (str
[k
]))
5198 /* Do it the hard way so as not to make any assumption about
5199 the relationship of unsigned long (%lu scan format code) and
5202 while (isdigit (str
[k
]))
5204 RU
= RU
* 10 + (str
[k
] - '0');
5211 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5217 /* NOTE on the above: Technically, C does not say what the results of
5218 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5219 number representable as a LONGEST (although either would probably work
5220 in most implementations). When RU>0, the locution in the then branch
5221 above is always equivalent to the negative of RU. */
5228 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5229 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5230 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5233 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5235 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5248 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5257 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5258 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5260 if (val
>= L
&& val
<= U
)
5272 /* FIXME: Lots of redundancy below. Try to consolidate. */
5274 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5275 ARG_TYPE, extract and return the value of one of its (non-static)
5276 fields. FIELDNO says which field. Differs from value_primitive_field
5277 only in that it can handle packed values of arbitrary type. */
5279 static struct value
*
5280 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5281 struct type
*arg_type
)
5285 arg_type
= ada_check_typedef (arg_type
);
5286 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5288 /* Handle packed fields. */
5290 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5292 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5293 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5295 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5296 offset
+ bit_pos
/ 8,
5297 bit_pos
% 8, bit_size
, type
);
5300 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5303 /* Find field with name NAME in object of type TYPE. If found, return 1
5304 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
5305 OFFSET + the byte offset of the field within an object of that type,
5306 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
5307 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
5308 Looks inside wrappers for the field. Returns 0 if field not
5311 find_struct_field (char *name
, struct type
*type
, int offset
,
5312 struct type
**field_type_p
,
5313 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
5317 type
= ada_check_typedef (type
);
5318 *field_type_p
= NULL
;
5319 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
5321 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5323 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
5324 int fld_offset
= offset
+ bit_pos
/ 8;
5325 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5327 if (t_field_name
== NULL
)
5330 else if (field_name_match (t_field_name
, name
))
5332 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
5333 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
5334 *byte_offset_p
= fld_offset
;
5335 *bit_offset_p
= bit_pos
% 8;
5336 *bit_size_p
= bit_size
;
5339 else if (ada_is_wrapper_field (type
, i
))
5341 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
5342 field_type_p
, byte_offset_p
, bit_offset_p
,
5346 else if (ada_is_variant_part (type
, i
))
5349 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5351 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5353 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
5355 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5356 field_type_p
, byte_offset_p
,
5357 bit_offset_p
, bit_size_p
))
5367 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5368 and search in it assuming it has (class) type TYPE.
5369 If found, return value, else return NULL.
5371 Searches recursively through wrapper fields (e.g., '_parent'). */
5373 static struct value
*
5374 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5378 type
= ada_check_typedef (type
);
5380 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5382 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5384 if (t_field_name
== NULL
)
5387 else if (field_name_match (t_field_name
, name
))
5388 return ada_value_primitive_field (arg
, offset
, i
, type
);
5390 else if (ada_is_wrapper_field (type
, i
))
5392 struct value
*v
= /* Do not let indent join lines here. */
5393 ada_search_struct_field (name
, arg
,
5394 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5395 TYPE_FIELD_TYPE (type
, i
));
5400 else if (ada_is_variant_part (type
, i
))
5403 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5404 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5406 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5408 struct value
*v
= ada_search_struct_field
/* Force line break. */
5410 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5411 TYPE_FIELD_TYPE (field_type
, j
));
5420 /* Given ARG, a value of type (pointer or reference to a)*
5421 structure/union, extract the component named NAME from the ultimate
5422 target structure/union and return it as a value with its
5423 appropriate type. If ARG is a pointer or reference and the field
5424 is not packed, returns a reference to the field, otherwise the
5425 value of the field (an lvalue if ARG is an lvalue).
5427 The routine searches for NAME among all members of the structure itself
5428 and (recursively) among all members of any wrapper members
5431 ERR is a name (for use in error messages) that identifies the class
5432 of entity that ARG is supposed to be. ERR may be null, indicating
5433 that on error, the function simply returns NULL, and does not
5434 throw an error. (FIXME: True only if ARG is a pointer or reference
5438 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5440 struct type
*t
, *t1
;
5444 t1
= t
= ada_check_typedef (VALUE_TYPE (arg
));
5445 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5447 t1
= TYPE_TARGET_TYPE (t
);
5453 error ("Bad value type in a %s.", err
);
5455 t1
= ada_check_typedef (t1
);
5456 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5463 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5465 t1
= TYPE_TARGET_TYPE (t
);
5471 error ("Bad value type in a %s.", err
);
5473 t1
= ada_check_typedef (t1
);
5474 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5476 arg
= value_ind (arg
);
5483 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
5488 error ("Attempt to extract a component of a value that is not a %s.",
5493 v
= ada_search_struct_field (name
, arg
, 0, t
);
5496 int bit_offset
, bit_size
, byte_offset
;
5497 struct type
*field_type
;
5500 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5501 address
= value_as_address (arg
);
5503 address
= unpack_pointer (t
, VALUE_CONTENTS (arg
));
5505 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
5506 if (find_struct_field (name
, t1
, 0,
5507 &field_type
, &byte_offset
, &bit_offset
,
5512 arg
= ada_value_ind (arg
);
5513 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
5514 bit_offset
, bit_size
,
5518 v
= value_from_pointer (lookup_reference_type (field_type
),
5519 address
+ byte_offset
);
5523 if (v
== NULL
&& err
!= NULL
)
5524 error ("There is no member named %s.", name
);
5529 /* Given a type TYPE, look up the type of the component of type named NAME.
5530 If DISPP is non-null, add its byte displacement from the beginning of a
5531 structure (pointed to by a value) of type TYPE to *DISPP (does not
5532 work for packed fields).
5534 Matches any field whose name has NAME as a prefix, possibly
5537 TYPE can be either a struct or union. If REFOK, TYPE may also
5538 be a (pointer or reference)+ to a struct or union, and the
5539 ultimate target type will be searched.
5541 Looks recursively into variant clauses and parent types.
5543 If NOERR is nonzero, return NULL if NAME is not suitably defined or
5544 TYPE is not a type of the right kind. */
5546 static struct type
*
5547 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
5548 int noerr
, int *dispp
)
5555 if (refok
&& type
!= NULL
)
5558 type
= ada_check_typedef (type
);
5559 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5560 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5562 type
= TYPE_TARGET_TYPE (type
);
5566 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
5567 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
5573 target_terminal_ours ();
5574 gdb_flush (gdb_stdout
);
5575 fprintf_unfiltered (gdb_stderr
, "Type ");
5577 fprintf_unfiltered (gdb_stderr
, "(null)");
5579 type_print (type
, "", gdb_stderr
, -1);
5580 error (" is not a structure or union type");
5584 type
= to_static_fixed_type (type
);
5586 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5588 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5592 if (t_field_name
== NULL
)
5595 else if (field_name_match (t_field_name
, name
))
5598 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5599 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5602 else if (ada_is_wrapper_field (type
, i
))
5605 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5610 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5615 else if (ada_is_variant_part (type
, i
))
5618 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5620 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5623 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5628 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5639 target_terminal_ours ();
5640 gdb_flush (gdb_stdout
);
5641 fprintf_unfiltered (gdb_stderr
, "Type ");
5642 type_print (type
, "", gdb_stderr
, -1);
5643 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5644 error ("%s", name
== NULL
? "<null>" : name
);
5650 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5651 within a value of type OUTER_TYPE that is stored in GDB at
5652 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5653 numbering from 0) is applicable. Returns -1 if none are. */
5656 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5657 char *outer_valaddr
)
5662 struct type
*discrim_type
;
5663 char *discrim_name
= ada_variant_discrim_name (var_type
);
5664 LONGEST discrim_val
;
5668 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
5669 if (discrim_type
== NULL
)
5671 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5674 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5676 if (ada_is_others_clause (var_type
, i
))
5678 else if (ada_in_variant (discrim_val
, var_type
, i
))
5682 return others_clause
;
5687 /* Dynamic-Sized Records */
5689 /* Strategy: The type ostensibly attached to a value with dynamic size
5690 (i.e., a size that is not statically recorded in the debugging
5691 data) does not accurately reflect the size or layout of the value.
5692 Our strategy is to convert these values to values with accurate,
5693 conventional types that are constructed on the fly. */
5695 /* There is a subtle and tricky problem here. In general, we cannot
5696 determine the size of dynamic records without its data. However,
5697 the 'struct value' data structure, which GDB uses to represent
5698 quantities in the inferior process (the target), requires the size
5699 of the type at the time of its allocation in order to reserve space
5700 for GDB's internal copy of the data. That's why the
5701 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5702 rather than struct value*s.
5704 However, GDB's internal history variables ($1, $2, etc.) are
5705 struct value*s containing internal copies of the data that are not, in
5706 general, the same as the data at their corresponding addresses in
5707 the target. Fortunately, the types we give to these values are all
5708 conventional, fixed-size types (as per the strategy described
5709 above), so that we don't usually have to perform the
5710 'to_fixed_xxx_type' conversions to look at their values.
5711 Unfortunately, there is one exception: if one of the internal
5712 history variables is an array whose elements are unconstrained
5713 records, then we will need to create distinct fixed types for each
5714 element selected. */
5716 /* The upshot of all of this is that many routines take a (type, host
5717 address, target address) triple as arguments to represent a value.
5718 The host address, if non-null, is supposed to contain an internal
5719 copy of the relevant data; otherwise, the program is to consult the
5720 target at the target address. */
5722 /* Assuming that VAL0 represents a pointer value, the result of
5723 dereferencing it. Differs from value_ind in its treatment of
5724 dynamic-sized types. */
5727 ada_value_ind (struct value
*val0
)
5729 struct value
*val
= unwrap_value (value_ind (val0
));
5730 return ada_to_fixed_value (val
);
5733 /* The value resulting from dereferencing any "reference to"
5734 qualifiers on VAL0. */
5736 static struct value
*
5737 ada_coerce_ref (struct value
*val0
)
5739 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5741 struct value
*val
= val0
;
5743 val
= unwrap_value (val
);
5744 return ada_to_fixed_value (val
);
5750 /* Return OFF rounded upward if necessary to a multiple of
5751 ALIGNMENT (a power of 2). */
5754 align_value (unsigned int off
, unsigned int alignment
)
5756 return (off
+ alignment
- 1) & ~(alignment
- 1);
5759 /* Return the bit alignment required for field #F of template type TYPE. */
5762 field_alignment (struct type
*type
, int f
)
5764 const char *name
= TYPE_FIELD_NAME (type
, f
);
5765 int len
= (name
== NULL
) ? 0 : strlen (name
);
5768 if (!isdigit (name
[len
- 1]))
5771 if (isdigit (name
[len
- 2]))
5772 align_offset
= len
- 2;
5774 align_offset
= len
- 1;
5776 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
5777 return TARGET_CHAR_BIT
;
5779 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5782 /* Find a symbol named NAME. Ignores ambiguity. */
5785 ada_find_any_symbol (const char *name
)
5789 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
5790 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5793 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
5797 /* Find a type named NAME. Ignores ambiguity. */
5800 ada_find_any_type (const char *name
)
5802 struct symbol
*sym
= ada_find_any_symbol (name
);
5805 return SYMBOL_TYPE (sym
);
5810 /* Given a symbol NAME and its associated BLOCK, search all symbols
5811 for its ___XR counterpart, which is the ``renaming'' symbol
5812 associated to NAME. Return this symbol if found, return
5816 ada_find_renaming_symbol (const char *name
, struct block
*block
)
5818 const struct symbol
*function_sym
= block_function (block
);
5821 if (function_sym
!= NULL
)
5823 /* If the symbol is defined inside a function, NAME is not fully
5824 qualified. This means we need to prepend the function name
5825 as well as adding the ``___XR'' suffix to build the name of
5826 the associated renaming symbol. */
5827 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
5828 const int function_name_len
= strlen (function_name
);
5829 const int rename_len
= function_name_len
+ 2 /* "__" */
5830 + strlen (name
) + 6 /* "___XR\0" */ ;
5832 /* Library-level functions are a special case, as GNAT adds
5833 a ``_ada_'' prefix to the function name to avoid namespace
5834 pollution. However, the renaming symbol themselves do not
5835 have this prefix, so we need to skip this prefix if present. */
5836 if (function_name_len
> 5 /* "_ada_" */
5837 && strstr (function_name
, "_ada_") == function_name
)
5838 function_name
= function_name
+ 5;
5840 rename
= (char *) alloca (rename_len
* sizeof (char));
5841 sprintf (rename
, "%s__%s___XR", function_name
, name
);
5845 const int rename_len
= strlen (name
) + 6;
5846 rename
= (char *) alloca (rename_len
* sizeof (char));
5847 sprintf (rename
, "%s___XR", name
);
5850 return ada_find_any_symbol (rename
);
5853 /* Because of GNAT encoding conventions, several GDB symbols may match a
5854 given type name. If the type denoted by TYPE0 is to be preferred to
5855 that of TYPE1 for purposes of type printing, return non-zero;
5856 otherwise return 0. */
5859 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5863 else if (type0
== NULL
)
5865 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5867 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5869 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
5871 else if (ada_is_packed_array_type (type0
))
5873 else if (ada_is_array_descriptor_type (type0
)
5874 && !ada_is_array_descriptor_type (type1
))
5876 else if (ada_renaming_type (type0
) != NULL
5877 && ada_renaming_type (type1
) == NULL
)
5882 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5883 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5886 ada_type_name (struct type
*type
)
5890 else if (TYPE_NAME (type
) != NULL
)
5891 return TYPE_NAME (type
);
5893 return TYPE_TAG_NAME (type
);
5896 /* Find a parallel type to TYPE whose name is formed by appending
5897 SUFFIX to the name of TYPE. */
5900 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5903 static size_t name_len
= 0;
5905 char *typename
= ada_type_name (type
);
5907 if (typename
== NULL
)
5910 len
= strlen (typename
);
5912 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5914 strcpy (name
, typename
);
5915 strcpy (name
+ len
, suffix
);
5917 return ada_find_any_type (name
);
5921 /* If TYPE is a variable-size record type, return the corresponding template
5922 type describing its fields. Otherwise, return NULL. */
5924 static struct type
*
5925 dynamic_template_type (struct type
*type
)
5927 type
= ada_check_typedef (type
);
5929 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5930 || ada_type_name (type
) == NULL
)
5934 int len
= strlen (ada_type_name (type
));
5935 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
5938 return ada_find_parallel_type (type
, "___XVE");
5942 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5943 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5946 is_dynamic_field (struct type
*templ_type
, int field_num
)
5948 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5950 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5951 && strstr (name
, "___XVL") != NULL
;
5954 /* The index of the variant field of TYPE, or -1 if TYPE does not
5955 represent a variant record type. */
5958 variant_field_index (struct type
*type
)
5962 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5965 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
5967 if (ada_is_variant_part (type
, f
))
5973 /* A record type with no fields. */
5975 static struct type
*
5976 empty_record (struct objfile
*objfile
)
5978 struct type
*type
= alloc_type (objfile
);
5979 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5980 TYPE_NFIELDS (type
) = 0;
5981 TYPE_FIELDS (type
) = NULL
;
5982 TYPE_NAME (type
) = "<empty>";
5983 TYPE_TAG_NAME (type
) = NULL
;
5984 TYPE_FLAGS (type
) = 0;
5985 TYPE_LENGTH (type
) = 0;
5989 /* An ordinary record type (with fixed-length fields) that describes
5990 the value of type TYPE at VALADDR or ADDRESS (see comments at
5991 the beginning of this section) VAL according to GNAT conventions.
5992 DVAL0 should describe the (portion of a) record that contains any
5993 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
5994 an outer-level type (i.e., as opposed to a branch of a variant.) A
5995 variant field (unless unchecked) is replaced by a particular branch
5998 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
5999 length are not statically known are discarded. As a consequence,
6000 VALADDR, ADDRESS and DVAL0 are ignored.
6002 NOTE: Limitations: For now, we assume that dynamic fields and
6003 variants occupy whole numbers of bytes. However, they need not be
6007 ada_template_to_fixed_record_type_1 (struct type
*type
, char *valaddr
,
6008 CORE_ADDR address
, struct value
*dval0
,
6009 int keep_dynamic_fields
)
6011 struct value
*mark
= value_mark ();
6014 int nfields
, bit_len
;
6017 int fld_bit_len
, bit_incr
;
6020 /* Compute the number of fields in this record type that are going
6021 to be processed: unless keep_dynamic_fields, this includes only
6022 fields whose position and length are static will be processed. */
6023 if (keep_dynamic_fields
)
6024 nfields
= TYPE_NFIELDS (type
);
6028 while (nfields
< TYPE_NFIELDS (type
)
6029 && !ada_is_variant_part (type
, nfields
)
6030 && !is_dynamic_field (type
, nfields
))
6034 rtype
= alloc_type (TYPE_OBJFILE (type
));
6035 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6036 INIT_CPLUS_SPECIFIC (rtype
);
6037 TYPE_NFIELDS (rtype
) = nfields
;
6038 TYPE_FIELDS (rtype
) = (struct field
*)
6039 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6040 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6041 TYPE_NAME (rtype
) = ada_type_name (type
);
6042 TYPE_TAG_NAME (rtype
) = NULL
;
6043 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6049 for (f
= 0; f
< nfields
; f
+= 1)
6051 off
= align_value (off
, field_alignment (type
, f
))
6052 + TYPE_FIELD_BITPOS (type
, f
);
6053 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6054 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6056 if (ada_is_variant_part (type
, f
))
6059 fld_bit_len
= bit_incr
= 0;
6061 else if (is_dynamic_field (type
, f
))
6064 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6068 TYPE_FIELD_TYPE (rtype
, f
) =
6071 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6072 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6073 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6074 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6075 bit_incr
= fld_bit_len
=
6076 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6080 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6081 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6082 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6083 bit_incr
= fld_bit_len
=
6084 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6086 bit_incr
= fld_bit_len
=
6087 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6089 if (off
+ fld_bit_len
> bit_len
)
6090 bit_len
= off
+ fld_bit_len
;
6092 TYPE_LENGTH (rtype
) =
6093 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6096 /* We handle the variant part, if any, at the end because of certain
6097 odd cases in which it is re-ordered so as NOT the last field of
6098 the record. This can happen in the presence of representation
6100 if (variant_field
>= 0)
6102 struct type
*branch_type
;
6104 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6107 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6112 to_fixed_variant_branch_type
6113 (TYPE_FIELD_TYPE (type
, variant_field
),
6114 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6115 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6116 if (branch_type
== NULL
)
6118 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6119 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6120 TYPE_NFIELDS (rtype
) -= 1;
6124 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6125 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6127 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6129 if (off
+ fld_bit_len
> bit_len
)
6130 bit_len
= off
+ fld_bit_len
;
6131 TYPE_LENGTH (rtype
) =
6132 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6136 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6138 value_free_to_mark (mark
);
6139 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6140 error ("record type with dynamic size is larger than varsize-limit");
6144 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6147 static struct type
*
6148 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6149 CORE_ADDR address
, struct value
*dval0
)
6151 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6155 /* An ordinary record type in which ___XVL-convention fields and
6156 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6157 static approximations, containing all possible fields. Uses
6158 no runtime values. Useless for use in values, but that's OK,
6159 since the results are used only for type determinations. Works on both
6160 structs and unions. Representation note: to save space, we memorize
6161 the result of this function in the TYPE_TARGET_TYPE of the
6164 static struct type
*
6165 template_to_static_fixed_type (struct type
*type0
)
6171 if (TYPE_TARGET_TYPE (type0
) != NULL
)
6172 return TYPE_TARGET_TYPE (type0
);
6174 nfields
= TYPE_NFIELDS (type0
);
6177 for (f
= 0; f
< nfields
; f
+= 1)
6179 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
6180 struct type
*new_type
;
6182 if (is_dynamic_field (type0
, f
))
6183 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
6185 new_type
= to_static_fixed_type (field_type
);
6186 if (type
== type0
&& new_type
!= field_type
)
6188 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
6189 TYPE_CODE (type
) = TYPE_CODE (type0
);
6190 INIT_CPLUS_SPECIFIC (type
);
6191 TYPE_NFIELDS (type
) = nfields
;
6192 TYPE_FIELDS (type
) = (struct field
*)
6193 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6194 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
6195 sizeof (struct field
) * nfields
);
6196 TYPE_NAME (type
) = ada_type_name (type0
);
6197 TYPE_TAG_NAME (type
) = NULL
;
6198 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
6199 TYPE_LENGTH (type
) = 0;
6201 TYPE_FIELD_TYPE (type
, f
) = new_type
;
6202 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
6207 /* Given an object of type TYPE whose contents are at VALADDR and
6208 whose address in memory is ADDRESS, returns a revision of TYPE --
6209 a non-dynamic-sized record with a variant part -- in which
6210 the variant part is replaced with the appropriate branch. Looks
6211 for discriminant values in DVAL0, which can be NULL if the record
6212 contains the necessary discriminant values. */
6214 static struct type
*
6215 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6216 CORE_ADDR address
, struct value
*dval0
)
6218 struct value
*mark
= value_mark ();
6221 struct type
*branch_type
;
6222 int nfields
= TYPE_NFIELDS (type
);
6223 int variant_field
= variant_field_index (type
);
6225 if (variant_field
== -1)
6229 dval
= value_from_contents_and_address (type
, valaddr
, address
);
6233 rtype
= alloc_type (TYPE_OBJFILE (type
));
6234 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6235 INIT_CPLUS_SPECIFIC (rtype
);
6236 TYPE_NFIELDS (rtype
) = nfields
;
6237 TYPE_FIELDS (rtype
) =
6238 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6239 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6240 sizeof (struct field
) * nfields
);
6241 TYPE_NAME (rtype
) = ada_type_name (type
);
6242 TYPE_TAG_NAME (rtype
) = NULL
;
6243 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6244 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6246 branch_type
= to_fixed_variant_branch_type
6247 (TYPE_FIELD_TYPE (type
, variant_field
),
6248 cond_offset_host (valaddr
,
6249 TYPE_FIELD_BITPOS (type
, variant_field
)
6251 cond_offset_target (address
,
6252 TYPE_FIELD_BITPOS (type
, variant_field
)
6253 / TARGET_CHAR_BIT
), dval
);
6254 if (branch_type
== NULL
)
6257 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
6258 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6259 TYPE_NFIELDS (rtype
) -= 1;
6263 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6264 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6265 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
6266 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6268 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
6270 value_free_to_mark (mark
);
6274 /* An ordinary record type (with fixed-length fields) that describes
6275 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6276 beginning of this section]. Any necessary discriminants' values
6277 should be in DVAL, a record value; it may be NULL if the object
6278 at ADDR itself contains any necessary discriminant values.
6279 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6280 values from the record are needed. Except in the case that DVAL,
6281 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6282 unchecked) is replaced by a particular branch of the variant.
6284 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6285 is questionable and may be removed. It can arise during the
6286 processing of an unconstrained-array-of-record type where all the
6287 variant branches have exactly the same size. This is because in
6288 such cases, the compiler does not bother to use the XVS convention
6289 when encoding the record. I am currently dubious of this
6290 shortcut and suspect the compiler should be altered. FIXME. */
6292 static struct type
*
6293 to_fixed_record_type (struct type
*type0
, char *valaddr
,
6294 CORE_ADDR address
, struct value
*dval
)
6296 struct type
*templ_type
;
6298 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6301 templ_type
= dynamic_template_type (type0
);
6303 if (templ_type
!= NULL
)
6304 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6305 else if (variant_field_index (type0
) >= 0)
6307 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
6309 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
6314 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
6320 /* An ordinary record type (with fixed-length fields) that describes
6321 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6322 union type. Any necessary discriminants' values should be in DVAL,
6323 a record value. That is, this routine selects the appropriate
6324 branch of the union at ADDR according to the discriminant value
6325 indicated in the union's type name. */
6327 static struct type
*
6328 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6329 CORE_ADDR address
, struct value
*dval
)
6332 struct type
*templ_type
;
6333 struct type
*var_type
;
6335 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6336 var_type
= TYPE_TARGET_TYPE (var_type0
);
6338 var_type
= var_type0
;
6340 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6342 if (templ_type
!= NULL
)
6343 var_type
= templ_type
;
6346 ada_which_variant_applies (var_type
,
6347 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6350 return empty_record (TYPE_OBJFILE (var_type
));
6351 else if (is_dynamic_field (var_type
, which
))
6352 return to_fixed_record_type
6353 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6354 valaddr
, address
, dval
);
6355 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
6357 to_fixed_record_type
6358 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6360 return TYPE_FIELD_TYPE (var_type
, which
);
6363 /* Assuming that TYPE0 is an array type describing the type of a value
6364 at ADDR, and that DVAL describes a record containing any
6365 discriminants used in TYPE0, returns a type for the value that
6366 contains no dynamic components (that is, no components whose sizes
6367 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6368 true, gives an error message if the resulting type's size is over
6371 static struct type
*
6372 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6375 struct type
*index_type_desc
;
6376 struct type
*result
;
6378 if (ada_is_packed_array_type (type0
) /* revisit? */
6379 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
6382 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6383 if (index_type_desc
== NULL
)
6385 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
6386 /* NOTE: elt_type---the fixed version of elt_type0---should never
6387 depend on the contents of the array in properly constructed
6389 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6391 if (elt_type0
== elt_type
)
6394 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6395 elt_type
, TYPE_INDEX_TYPE (type0
));
6400 struct type
*elt_type0
;
6403 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6404 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6406 /* NOTE: result---the fixed version of elt_type0---should never
6407 depend on the contents of the array in properly constructed
6409 result
= ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
);
6410 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6412 struct type
*range_type
=
6413 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6414 dval
, TYPE_OBJFILE (type0
));
6415 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6416 result
, range_type
);
6418 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6419 error ("array type with dynamic size is larger than varsize-limit");
6422 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
6427 /* A standard type (containing no dynamically sized components)
6428 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6429 DVAL describes a record containing any discriminants used in TYPE0,
6430 and may be NULL if there are none, or if the object of type TYPE at
6431 ADDRESS or in VALADDR contains these discriminants. */
6434 ada_to_fixed_type (struct type
*type
, char *valaddr
,
6435 CORE_ADDR address
, struct value
*dval
)
6437 type
= ada_check_typedef (type
);
6438 switch (TYPE_CODE (type
))
6442 case TYPE_CODE_STRUCT
:
6444 struct type
*static_type
= to_static_fixed_type (type
);
6445 if (ada_is_tagged_type (static_type
, 0))
6447 struct type
*real_type
=
6448 type_from_tag (value_tag_from_contents_and_address (static_type
,
6451 if (real_type
!= NULL
)
6454 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6456 case TYPE_CODE_ARRAY
:
6457 return to_fixed_array_type (type
, dval
, 1);
6458 case TYPE_CODE_UNION
:
6462 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6466 /* A standard (static-sized) type corresponding as well as possible to
6467 TYPE0, but based on no runtime data. */
6469 static struct type
*
6470 to_static_fixed_type (struct type
*type0
)
6477 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6480 type0
= ada_check_typedef (type0
);
6482 switch (TYPE_CODE (type0
))
6486 case TYPE_CODE_STRUCT
:
6487 type
= dynamic_template_type (type0
);
6489 return template_to_static_fixed_type (type
);
6491 return template_to_static_fixed_type (type0
);
6492 case TYPE_CODE_UNION
:
6493 type
= ada_find_parallel_type (type0
, "___XVU");
6495 return template_to_static_fixed_type (type
);
6497 return template_to_static_fixed_type (type0
);
6501 /* A static approximation of TYPE with all type wrappers removed. */
6503 static struct type
*
6504 static_unwrap_type (struct type
*type
)
6506 if (ada_is_aligner_type (type
))
6508 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
6509 if (ada_type_name (type1
) == NULL
)
6510 TYPE_NAME (type1
) = ada_type_name (type
);
6512 return static_unwrap_type (type1
);
6516 struct type
*raw_real_type
= ada_get_base_type (type
);
6517 if (raw_real_type
== type
)
6520 return to_static_fixed_type (raw_real_type
);
6524 /* In some cases, incomplete and private types require
6525 cross-references that are not resolved as records (for example,
6527 type FooP is access Foo;
6529 type Foo is array ...;
6530 ). In these cases, since there is no mechanism for producing
6531 cross-references to such types, we instead substitute for FooP a
6532 stub enumeration type that is nowhere resolved, and whose tag is
6533 the name of the actual type. Call these types "non-record stubs". */
6535 /* A type equivalent to TYPE that is not a non-record stub, if one
6536 exists, otherwise TYPE. */
6539 ada_check_typedef (struct type
*type
)
6541 CHECK_TYPEDEF (type
);
6542 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6543 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6544 || TYPE_TAG_NAME (type
) == NULL
)
6548 char *name
= TYPE_TAG_NAME (type
);
6549 struct type
*type1
= ada_find_any_type (name
);
6550 return (type1
== NULL
) ? type
: type1
;
6554 /* A value representing the data at VALADDR/ADDRESS as described by
6555 type TYPE0, but with a standard (static-sized) type that correctly
6556 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6557 type, then return VAL0 [this feature is simply to avoid redundant
6558 creation of struct values]. */
6560 static struct value
*
6561 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
6564 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
6565 if (type
== type0
&& val0
!= NULL
)
6568 return value_from_contents_and_address (type
, 0, address
);
6571 /* A value representing VAL, but with a standard (static-sized) type
6572 that correctly describes it. Does not necessarily create a new
6575 static struct value
*
6576 ada_to_fixed_value (struct value
*val
)
6578 return ada_to_fixed_value_create (VALUE_TYPE (val
),
6579 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6583 /* A value representing VAL, but with a standard (static-sized) type
6584 chosen to approximate the real type of VAL as well as possible, but
6585 without consulting any runtime values. For Ada dynamic-sized
6586 types, therefore, the type of the result is likely to be inaccurate. */
6589 ada_to_static_fixed_value (struct value
*val
)
6592 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6593 if (type
== VALUE_TYPE (val
))
6596 return coerce_unspec_val_to_type (val
, type
);
6602 /* Table mapping attribute numbers to names.
6603 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
6605 static const char *attribute_names
[] = {
6623 ada_attribute_name (enum exp_opcode n
)
6625 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
6626 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
6628 return attribute_names
[0];
6631 /* Evaluate the 'POS attribute applied to ARG. */
6634 pos_atr (struct value
*arg
)
6636 struct type
*type
= VALUE_TYPE (arg
);
6638 if (!discrete_type_p (type
))
6639 error ("'POS only defined on discrete types");
6641 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6644 LONGEST v
= value_as_long (arg
);
6646 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6648 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6651 error ("enumeration value is invalid: can't find 'POS");
6654 return value_as_long (arg
);
6657 static struct value
*
6658 value_pos_atr (struct value
*arg
)
6660 return value_from_longest (builtin_type_int
, pos_atr (arg
));
6663 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6665 static struct value
*
6666 value_val_atr (struct type
*type
, struct value
*arg
)
6668 if (!discrete_type_p (type
))
6669 error ("'VAL only defined on discrete types");
6670 if (!integer_type_p (VALUE_TYPE (arg
)))
6671 error ("'VAL requires integral argument");
6673 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6675 long pos
= value_as_long (arg
);
6676 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6677 error ("argument to 'VAL out of range");
6678 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6681 return value_from_longest (type
, value_as_long (arg
));
6687 /* True if TYPE appears to be an Ada character type.
6688 [At the moment, this is true only for Character and Wide_Character;
6689 It is a heuristic test that could stand improvement]. */
6692 ada_is_character_type (struct type
*type
)
6694 const char *name
= ada_type_name (type
);
6697 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6698 || TYPE_CODE (type
) == TYPE_CODE_INT
6699 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6700 && (strcmp (name
, "character") == 0
6701 || strcmp (name
, "wide_character") == 0
6702 || strcmp (name
, "unsigned char") == 0);
6705 /* True if TYPE appears to be an Ada string type. */
6708 ada_is_string_type (struct type
*type
)
6710 type
= ada_check_typedef (type
);
6712 && TYPE_CODE (type
) != TYPE_CODE_PTR
6713 && (ada_is_simple_array_type (type
)
6714 || ada_is_array_descriptor_type (type
))
6715 && ada_array_arity (type
) == 1)
6717 struct type
*elttype
= ada_array_element_type (type
, 1);
6719 return ada_is_character_type (elttype
);
6726 /* True if TYPE is a struct type introduced by the compiler to force the
6727 alignment of a value. Such types have a single field with a
6728 distinctive name. */
6731 ada_is_aligner_type (struct type
*type
)
6733 type
= ada_check_typedef (type
);
6734 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6735 && TYPE_NFIELDS (type
) == 1
6736 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
6739 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6740 the parallel type. */
6743 ada_get_base_type (struct type
*raw_type
)
6745 struct type
*real_type_namer
;
6746 struct type
*raw_real_type
;
6748 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6751 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6752 if (real_type_namer
== NULL
6753 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6754 || TYPE_NFIELDS (real_type_namer
) != 1)
6757 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6758 if (raw_real_type
== NULL
)
6761 return raw_real_type
;
6764 /* The type of value designated by TYPE, with all aligners removed. */
6767 ada_aligned_type (struct type
*type
)
6769 if (ada_is_aligner_type (type
))
6770 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6772 return ada_get_base_type (type
);
6776 /* The address of the aligned value in an object at address VALADDR
6777 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6780 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6782 if (ada_is_aligner_type (type
))
6783 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6785 TYPE_FIELD_BITPOS (type
,
6786 0) / TARGET_CHAR_BIT
);
6793 /* The printed representation of an enumeration literal with encoded
6794 name NAME. The value is good to the next call of ada_enum_name. */
6796 ada_enum_name (const char *name
)
6798 static char *result
;
6799 static size_t result_len
= 0;
6802 /* First, unqualify the enumeration name:
6803 1. Search for the last '.' character. If we find one, then skip
6804 all the preceeding characters, the unqualified name starts
6805 right after that dot.
6806 2. Otherwise, we may be debugging on a target where the compiler
6807 translates dots into "__". Search forward for double underscores,
6808 but stop searching when we hit an overloading suffix, which is
6809 of the form "__" followed by digits. */
6811 tmp
= strrchr (name
, '.');
6816 while ((tmp
= strstr (name
, "__")) != NULL
)
6818 if (isdigit (tmp
[2]))
6828 if (name
[1] == 'U' || name
[1] == 'W')
6830 if (sscanf (name
+ 2, "%x", &v
) != 1)
6836 GROW_VECT (result
, result_len
, 16);
6837 if (isascii (v
) && isprint (v
))
6838 sprintf (result
, "'%c'", v
);
6839 else if (name
[1] == 'U')
6840 sprintf (result
, "[\"%02x\"]", v
);
6842 sprintf (result
, "[\"%04x\"]", v
);
6848 tmp
= strstr (name
, "__");
6850 tmp
= strstr (name
, "$");
6853 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
6854 strncpy (result
, name
, tmp
- name
);
6855 result
[tmp
- name
] = '\0';
6863 static struct value
*
6864 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6867 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6868 (expect_type
, exp
, pos
, noside
);
6871 /* Evaluate the subexpression of EXP starting at *POS as for
6872 evaluate_type, updating *POS to point just past the evaluated
6875 static struct value
*
6876 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6878 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6879 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6882 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6885 static struct value
*
6886 unwrap_value (struct value
*val
)
6888 struct type
*type
= ada_check_typedef (VALUE_TYPE (val
));
6889 if (ada_is_aligner_type (type
))
6891 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6892 NULL
, "internal structure");
6893 struct type
*val_type
= ada_check_typedef (VALUE_TYPE (v
));
6894 if (ada_type_name (val_type
) == NULL
)
6895 TYPE_NAME (val_type
) = ada_type_name (type
);
6897 return unwrap_value (v
);
6901 struct type
*raw_real_type
=
6902 ada_check_typedef (ada_get_base_type (type
));
6904 if (type
== raw_real_type
)
6908 coerce_unspec_val_to_type
6909 (val
, ada_to_fixed_type (raw_real_type
, 0,
6910 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6915 static struct value
*
6916 cast_to_fixed (struct type
*type
, struct value
*arg
)
6920 if (type
== VALUE_TYPE (arg
))
6922 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6923 val
= ada_float_to_fixed (type
,
6924 ada_fixed_to_float (VALUE_TYPE (arg
),
6925 value_as_long (arg
)));
6929 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6930 val
= ada_float_to_fixed (type
, argd
);
6933 return value_from_longest (type
, val
);
6936 static struct value
*
6937 cast_from_fixed_to_double (struct value
*arg
)
6939 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6940 value_as_long (arg
));
6941 return value_from_double (builtin_type_double
, val
);
6944 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6945 return the converted value. */
6947 static struct value
*
6948 coerce_for_assign (struct type
*type
, struct value
*val
)
6950 struct type
*type2
= VALUE_TYPE (val
);
6954 type2
= ada_check_typedef (type2
);
6955 type
= ada_check_typedef (type
);
6957 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6958 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6960 val
= ada_value_ind (val
);
6961 type2
= VALUE_TYPE (val
);
6964 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6965 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6967 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6968 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6969 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6970 error ("Incompatible types in assignment");
6971 VALUE_TYPE (val
) = type
;
6976 static struct value
*
6977 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
6980 struct type
*type1
, *type2
;
6985 type1
= base_type (ada_check_typedef (VALUE_TYPE (arg1
)));
6986 type2
= base_type (ada_check_typedef (VALUE_TYPE (arg2
)));
6988 if (TYPE_CODE (type1
) != TYPE_CODE_INT
6989 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
6990 return value_binop (arg1
, arg2
, op
);
6999 return value_binop (arg1
, arg2
, op
);
7002 v2
= value_as_long (arg2
);
7004 error ("second operand of %s must not be zero.", op_string (op
));
7006 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7007 return value_binop (arg1
, arg2
, op
);
7009 v1
= value_as_long (arg1
);
7014 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7015 v
+= v
> 0 ? -1 : 1;
7023 /* Should not reach this point. */
7027 val
= allocate_value (type1
);
7028 store_unsigned_integer (VALUE_CONTENTS_RAW (val
),
7029 TYPE_LENGTH (VALUE_TYPE (val
)), v
);
7034 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7036 if (ada_is_direct_array_type (VALUE_TYPE (arg1
))
7037 || ada_is_direct_array_type (VALUE_TYPE (arg2
)))
7039 arg1
= ada_coerce_to_simple_array (arg1
);
7040 arg2
= ada_coerce_to_simple_array (arg2
);
7041 if (TYPE_CODE (VALUE_TYPE (arg1
)) != TYPE_CODE_ARRAY
7042 || TYPE_CODE (VALUE_TYPE (arg2
)) != TYPE_CODE_ARRAY
)
7043 error ("Attempt to compare array with non-array");
7044 /* FIXME: The following works only for types whose
7045 representations use all bits (no padding or undefined bits)
7046 and do not have user-defined equality. */
7048 TYPE_LENGTH (VALUE_TYPE (arg1
)) == TYPE_LENGTH (VALUE_TYPE (arg2
))
7049 && memcmp (VALUE_CONTENTS (arg1
), VALUE_CONTENTS (arg2
),
7050 TYPE_LENGTH (VALUE_TYPE (arg1
))) == 0;
7052 return value_equal (arg1
, arg2
);
7056 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
7057 int *pos
, enum noside noside
)
7060 int tem
, tem2
, tem3
;
7062 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
7065 struct value
**argvec
;
7069 op
= exp
->elts
[pc
].opcode
;
7076 unwrap_value (evaluate_subexp_standard
7077 (expect_type
, exp
, pos
, noside
));
7081 struct value
*result
;
7083 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
7084 /* The result type will have code OP_STRING, bashed there from
7085 OP_ARRAY. Bash it back. */
7086 if (TYPE_CODE (VALUE_TYPE (result
)) == TYPE_CODE_STRING
)
7087 TYPE_CODE (VALUE_TYPE (result
)) = TYPE_CODE_ARRAY
;
7093 type
= exp
->elts
[pc
+ 1].type
;
7094 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
7095 if (noside
== EVAL_SKIP
)
7097 if (type
!= ada_check_typedef (VALUE_TYPE (arg1
)))
7099 if (ada_is_fixed_point_type (type
))
7100 arg1
= cast_to_fixed (type
, arg1
);
7101 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7102 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
7103 else if (VALUE_LVAL (arg1
) == lval_memory
)
7105 /* This is in case of the really obscure (and undocumented,
7106 but apparently expected) case of (Foo) Bar.all, where Bar
7107 is an integer constant and Foo is a dynamic-sized type.
7108 If we don't do this, ARG1 will simply be relabeled with
7110 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7111 return value_zero (to_static_fixed_type (type
), not_lval
);
7113 ada_to_fixed_value_create
7114 (type
, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
7117 arg1
= value_cast (type
, arg1
);
7123 type
= exp
->elts
[pc
+ 1].type
;
7124 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
7127 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7128 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
7129 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7131 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7132 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
7133 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
7135 ("Fixed-point values must be assigned to fixed-point variables");
7137 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
7138 return ada_value_assign (arg1
, arg2
);
7141 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7142 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7143 if (noside
== EVAL_SKIP
)
7145 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
7146 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
7147 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
7148 error ("Operands of fixed-point addition must have the same type");
7149 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
7152 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7153 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7154 if (noside
== EVAL_SKIP
)
7156 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
7157 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
7158 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
7159 error ("Operands of fixed-point subtraction must have the same type");
7160 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
7164 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7165 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7166 if (noside
== EVAL_SKIP
)
7168 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7169 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7170 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7173 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7174 arg1
= cast_from_fixed_to_double (arg1
);
7175 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
7176 arg2
= cast_from_fixed_to_double (arg2
);
7177 return ada_value_binop (arg1
, arg2
, op
);
7182 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7183 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7184 if (noside
== EVAL_SKIP
)
7186 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7187 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7188 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7190 return ada_value_binop (arg1
, arg2
, op
);
7193 case BINOP_NOTEQUAL
:
7194 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7195 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
7196 if (noside
== EVAL_SKIP
)
7198 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7201 tem
= ada_value_equal (arg1
, arg2
);
7202 if (op
== BINOP_NOTEQUAL
)
7204 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
7207 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7208 if (noside
== EVAL_SKIP
)
7210 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7211 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
7213 return value_neg (arg1
);
7217 if (noside
== EVAL_SKIP
)
7222 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
7223 /* Only encountered when an unresolved symbol occurs in a
7224 context other than a function call, in which case, it is
7226 error ("Unexpected unresolved symbol, %s, during evaluation",
7227 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
7228 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7232 (to_static_fixed_type
7233 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7239 unwrap_value (evaluate_subexp_standard
7240 (expect_type
, exp
, pos
, noside
));
7241 return ada_to_fixed_value (arg1
);
7247 /* Allocate arg vector, including space for the function to be
7248 called in argvec[0] and a terminating NULL. */
7249 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7251 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
7253 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
7254 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
7255 error ("Unexpected unresolved symbol, %s, during evaluation",
7256 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
7259 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7260 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7263 if (noside
== EVAL_SKIP
)
7267 if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec
[0]))))
7268 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7269 else if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
7270 || (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_ARRAY
7271 && VALUE_LVAL (argvec
[0]) == lval_memory
))
7272 argvec
[0] = value_addr (argvec
[0]);
7274 type
= ada_check_typedef (VALUE_TYPE (argvec
[0]));
7275 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7277 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
7279 case TYPE_CODE_FUNC
:
7280 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7282 case TYPE_CODE_ARRAY
:
7284 case TYPE_CODE_STRUCT
:
7285 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7286 argvec
[0] = ada_value_ind (argvec
[0]);
7287 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7290 error ("cannot subscript or call something of type `%s'",
7291 ada_type_name (VALUE_TYPE (argvec
[0])));
7296 switch (TYPE_CODE (type
))
7298 case TYPE_CODE_FUNC
:
7299 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7300 return allocate_value (TYPE_TARGET_TYPE (type
));
7301 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7302 case TYPE_CODE_STRUCT
:
7306 arity
= ada_array_arity (type
);
7307 type
= ada_array_element_type (type
, nargs
);
7309 error ("cannot subscript or call a record");
7311 error ("wrong number of subscripts; expecting %d", arity
);
7312 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7313 return allocate_value (ada_aligned_type (type
));
7315 unwrap_value (ada_value_subscript
7316 (argvec
[0], nargs
, argvec
+ 1));
7318 case TYPE_CODE_ARRAY
:
7319 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7321 type
= ada_array_element_type (type
, nargs
);
7323 error ("element type of array unknown");
7325 return allocate_value (ada_aligned_type (type
));
7328 unwrap_value (ada_value_subscript
7329 (ada_coerce_to_simple_array (argvec
[0]),
7330 nargs
, argvec
+ 1));
7331 case TYPE_CODE_PTR
: /* Pointer to array */
7332 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7333 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7335 type
= ada_array_element_type (type
, nargs
);
7337 error ("element type of array unknown");
7339 return allocate_value (ada_aligned_type (type
));
7342 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7343 nargs
, argvec
+ 1));
7346 error ("Internal error in evaluate_subexp");
7351 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7352 struct value
*low_bound_val
=
7353 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7354 LONGEST low_bound
= pos_atr (low_bound_val
);
7356 = pos_atr (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7358 if (noside
== EVAL_SKIP
)
7361 /* If this is a reference to an aligner type, then remove all
7363 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7364 && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
))))
7365 TYPE_TARGET_TYPE (VALUE_TYPE (array
)) =
7366 ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)));
7368 if (ada_is_packed_array_type (VALUE_TYPE (array
)))
7369 error ("cannot slice a packed array");
7371 /* If this is a reference to an array or an array lvalue,
7372 convert to a pointer. */
7373 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7374 || (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_ARRAY
7375 && VALUE_LVAL (array
) == lval_memory
))
7376 array
= value_addr (array
);
7378 if (noside
== EVAL_AVOID_SIDE_EFFECTS
7379 && ada_is_array_descriptor_type (ada_check_typedef
7380 (VALUE_TYPE (array
))))
7381 return empty_array (ada_type_of_array (array
, 0), low_bound
);
7383 array
= ada_coerce_to_simple_array_ptr (array
);
7385 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
)
7387 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7388 return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
7392 struct type
*arr_type0
=
7393 to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
7395 return ada_value_slice_ptr (array
, arr_type0
,
7400 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7402 else if (high_bound
< low_bound
)
7403 return empty_array (VALUE_TYPE (array
), low_bound
);
7405 return ada_value_slice (array
, (int) low_bound
, (int) high_bound
);
7410 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7411 type
= exp
->elts
[pc
+ 1].type
;
7413 if (noside
== EVAL_SKIP
)
7416 switch (TYPE_CODE (type
))
7419 lim_warning ("Membership test incompletely implemented; "
7420 "always returns true", 0);
7421 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
7423 case TYPE_CODE_RANGE
:
7424 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
7425 arg3
= value_from_longest (builtin_type_int
,
7426 TYPE_HIGH_BOUND (type
));
7428 value_from_longest (builtin_type_int
,
7429 (value_less (arg1
, arg3
)
7430 || value_equal (arg1
, arg3
))
7431 && (value_less (arg2
, arg1
)
7432 || value_equal (arg2
, arg1
)));
7435 case BINOP_IN_BOUNDS
:
7437 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7438 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7440 if (noside
== EVAL_SKIP
)
7443 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7444 return value_zero (builtin_type_int
, not_lval
);
7446 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7448 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg2
)))
7449 error ("invalid dimension number to '%s", "range");
7451 arg3
= ada_array_bound (arg2
, tem
, 1);
7452 arg2
= ada_array_bound (arg2
, tem
, 0);
7455 value_from_longest (builtin_type_int
,
7456 (value_less (arg1
, arg3
)
7457 || value_equal (arg1
, arg3
))
7458 && (value_less (arg2
, arg1
)
7459 || value_equal (arg2
, arg1
)));
7461 case TERNOP_IN_RANGE
:
7462 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7463 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7464 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7466 if (noside
== EVAL_SKIP
)
7470 value_from_longest (builtin_type_int
,
7471 (value_less (arg1
, arg3
)
7472 || value_equal (arg1
, arg3
))
7473 && (value_less (arg2
, arg1
)
7474 || value_equal (arg2
, arg1
)));
7480 struct type
*type_arg
;
7481 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
7483 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7485 type_arg
= exp
->elts
[pc
+ 2].type
;
7489 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7493 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
7494 error ("illegal operand to '%s", ada_attribute_name (op
));
7495 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
7498 if (noside
== EVAL_SKIP
)
7501 if (type_arg
== NULL
)
7503 arg1
= ada_coerce_ref (arg1
);
7505 if (ada_is_packed_array_type (VALUE_TYPE (arg1
)))
7506 arg1
= ada_coerce_to_simple_array (arg1
);
7508 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg1
)))
7509 error ("invalid dimension number to '%s",
7510 ada_attribute_name (op
));
7512 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7514 type
= ada_index_type (VALUE_TYPE (arg1
), tem
);
7517 ("attempt to take bound of something that is not an array");
7518 return allocate_value (type
);
7523 default: /* Should never happen. */
7524 error ("unexpected attribute encountered");
7526 return ada_array_bound (arg1
, tem
, 0);
7528 return ada_array_bound (arg1
, tem
, 1);
7530 return ada_array_length (arg1
, tem
);
7533 else if (discrete_type_p (type_arg
))
7535 struct type
*range_type
;
7536 char *name
= ada_type_name (type_arg
);
7538 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
7540 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
7541 if (range_type
== NULL
)
7542 range_type
= type_arg
;
7546 error ("unexpected attribute encountered");
7548 return discrete_type_low_bound (range_type
);
7550 return discrete_type_high_bound (range_type
);
7552 error ("the 'length attribute applies only to array types");
7555 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
7556 error ("unimplemented type attribute");
7561 if (ada_is_packed_array_type (type_arg
))
7562 type_arg
= decode_packed_array_type (type_arg
);
7564 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
7565 error ("invalid dimension number to '%s",
7566 ada_attribute_name (op
));
7568 type
= ada_index_type (type_arg
, tem
);
7571 ("attempt to take bound of something that is not an array");
7572 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7573 return allocate_value (type
);
7578 error ("unexpected attribute encountered");
7580 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7581 return value_from_longest (type
, low
);
7583 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
7584 return value_from_longest (type
, high
);
7586 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7587 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
7588 return value_from_longest (type
, high
- low
+ 1);
7594 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7595 if (noside
== EVAL_SKIP
)
7598 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7599 return value_zero (ada_tag_type (arg1
), not_lval
);
7601 return ada_value_tag (arg1
);
7605 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7606 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7607 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7608 if (noside
== EVAL_SKIP
)
7610 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7611 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7613 return value_binop (arg1
, arg2
,
7614 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
7616 case OP_ATR_MODULUS
:
7618 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
7619 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7621 if (noside
== EVAL_SKIP
)
7624 if (!ada_is_modular_type (type_arg
))
7625 error ("'modulus must be applied to modular type");
7627 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
7628 ada_modulus (type_arg
));
7633 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7634 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7635 if (noside
== EVAL_SKIP
)
7637 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7638 return value_zero (builtin_type_int
, not_lval
);
7640 return value_pos_atr (arg1
);
7643 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7644 if (noside
== EVAL_SKIP
)
7646 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7647 return value_zero (builtin_type_int
, not_lval
);
7649 return value_from_longest (builtin_type_int
,
7651 * TYPE_LENGTH (VALUE_TYPE (arg1
)));
7654 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7655 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7656 type
= exp
->elts
[pc
+ 2].type
;
7657 if (noside
== EVAL_SKIP
)
7659 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7660 return value_zero (type
, not_lval
);
7662 return value_val_atr (type
, arg1
);
7665 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7666 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7667 if (noside
== EVAL_SKIP
)
7669 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7670 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7672 return value_binop (arg1
, arg2
, op
);
7675 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7676 if (noside
== EVAL_SKIP
)
7682 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7683 if (noside
== EVAL_SKIP
)
7685 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7686 return value_neg (arg1
);
7691 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7692 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
7693 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7694 if (noside
== EVAL_SKIP
)
7696 type
= ada_check_typedef (VALUE_TYPE (arg1
));
7697 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7699 if (ada_is_array_descriptor_type (type
))
7700 /* GDB allows dereferencing GNAT array descriptors. */
7702 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7703 if (arrType
== NULL
)
7704 error ("Attempt to dereference null array pointer.");
7705 return value_at_lazy (arrType
, 0, NULL
);
7707 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7708 || TYPE_CODE (type
) == TYPE_CODE_REF
7709 /* In C you can dereference an array to get the 1st elt. */
7710 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7713 (to_static_fixed_type
7714 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7716 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7717 /* GDB allows dereferencing an int. */
7718 return value_zero (builtin_type_int
, lval_memory
);
7720 error ("Attempt to take contents of a non-pointer value.");
7722 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
7723 type
= ada_check_typedef (VALUE_TYPE (arg1
));
7725 if (ada_is_array_descriptor_type (type
))
7726 /* GDB allows dereferencing GNAT array descriptors. */
7727 return ada_coerce_to_simple_array (arg1
);
7729 return ada_value_ind (arg1
);
7731 case STRUCTOP_STRUCT
:
7732 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7733 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7734 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7735 if (noside
== EVAL_SKIP
)
7737 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7739 struct type
*type1
= VALUE_TYPE (arg1
);
7740 if (ada_is_tagged_type (type1
, 1))
7742 type
= ada_lookup_struct_elt_type (type1
,
7743 &exp
->elts
[pc
+ 2].string
,
7746 /* In this case, we assume that the field COULD exist
7747 in some extension of the type. Return an object of
7748 "type" void, which will match any formal
7749 (see ada_type_match). */
7750 return value_zero (builtin_type_void
, lval_memory
);
7754 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
7757 return value_zero (ada_aligned_type (type
), lval_memory
);
7761 ada_to_fixed_value (unwrap_value
7762 (ada_value_struct_elt
7763 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
7765 /* The value is not supposed to be used. This is here to make it
7766 easier to accommodate expressions that contain types. */
7768 if (noside
== EVAL_SKIP
)
7770 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7771 return allocate_value (builtin_type_void
);
7773 error ("Attempt to use a type name as an expression");
7777 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7783 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7784 type name that encodes the 'small and 'delta information.
7785 Otherwise, return NULL. */
7788 fixed_type_info (struct type
*type
)
7790 const char *name
= ada_type_name (type
);
7791 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7793 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7795 const char *tail
= strstr (name
, "___XF_");
7801 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7802 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7807 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7810 ada_is_fixed_point_type (struct type
*type
)
7812 return fixed_type_info (type
) != NULL
;
7815 /* Return non-zero iff TYPE represents a System.Address type. */
7818 ada_is_system_address_type (struct type
*type
)
7820 return (TYPE_NAME (type
)
7821 && strcmp (TYPE_NAME (type
), "system__address") == 0);
7824 /* Assuming that TYPE is the representation of an Ada fixed-point
7825 type, return its delta, or -1 if the type is malformed and the
7826 delta cannot be determined. */
7829 ada_delta (struct type
*type
)
7831 const char *encoding
= fixed_type_info (type
);
7834 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7837 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7840 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7841 factor ('SMALL value) associated with the type. */
7844 scaling_factor (struct type
*type
)
7846 const char *encoding
= fixed_type_info (type
);
7847 unsigned long num0
, den0
, num1
, den1
;
7850 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7855 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7857 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7861 /* Assuming that X is the representation of a value of fixed-point
7862 type TYPE, return its floating-point equivalent. */
7865 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7867 return (DOUBLEST
) x
*scaling_factor (type
);
7870 /* The representation of a fixed-point value of type TYPE
7871 corresponding to the value X. */
7874 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7876 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7880 /* VAX floating formats */
7882 /* Non-zero iff TYPE represents one of the special VAX floating-point
7886 ada_is_vax_floating_type (struct type
*type
)
7889 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7892 && (TYPE_CODE (type
) == TYPE_CODE_INT
7893 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7894 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
7897 /* The type of special VAX floating-point type this is, assuming
7898 ada_is_vax_floating_point. */
7901 ada_vax_float_type_suffix (struct type
*type
)
7903 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7906 /* A value representing the special debugging function that outputs
7907 VAX floating-point values of the type represented by TYPE. Assumes
7908 ada_is_vax_floating_type (TYPE). */
7911 ada_vax_float_print_function (struct type
*type
)
7913 switch (ada_vax_float_type_suffix (type
))
7916 return get_var_value ("DEBUG_STRING_F", 0);
7918 return get_var_value ("DEBUG_STRING_D", 0);
7920 return get_var_value ("DEBUG_STRING_G", 0);
7922 error ("invalid VAX floating-point type");
7929 /* Scan STR beginning at position K for a discriminant name, and
7930 return the value of that discriminant field of DVAL in *PX. If
7931 PNEW_K is not null, put the position of the character beyond the
7932 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7933 not alter *PX and *PNEW_K if unsuccessful. */
7936 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
7939 static char *bound_buffer
= NULL
;
7940 static size_t bound_buffer_len
= 0;
7943 struct value
*bound_val
;
7945 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7948 pend
= strstr (str
+ k
, "__");
7952 k
+= strlen (bound
);
7956 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7957 bound
= bound_buffer
;
7958 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7959 bound
[pend
- (str
+ k
)] = '\0';
7963 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7964 if (bound_val
== NULL
)
7967 *px
= value_as_long (bound_val
);
7973 /* Value of variable named NAME in the current environment. If
7974 no such variable found, then if ERR_MSG is null, returns 0, and
7975 otherwise causes an error with message ERR_MSG. */
7977 static struct value
*
7978 get_var_value (char *name
, char *err_msg
)
7980 struct ada_symbol_info
*syms
;
7983 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
7988 if (err_msg
== NULL
)
7991 error ("%s", err_msg
);
7994 return value_of_variable (syms
[0].sym
, syms
[0].block
);
7997 /* Value of integer variable named NAME in the current environment. If
7998 no such variable found, returns 0, and sets *FLAG to 0. If
7999 successful, sets *FLAG to 1. */
8002 get_int_var_value (char *name
, int *flag
)
8004 struct value
*var_val
= get_var_value (name
, 0);
8016 return value_as_long (var_val
);
8021 /* Return a range type whose base type is that of the range type named
8022 NAME in the current environment, and whose bounds are calculated
8023 from NAME according to the GNAT range encoding conventions.
8024 Extract discriminant values, if needed, from DVAL. If a new type
8025 must be created, allocate in OBJFILE's space. The bounds
8026 information, in general, is encoded in NAME, the base type given in
8027 the named range type. */
8029 static struct type
*
8030 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
8032 struct type
*raw_type
= ada_find_any_type (name
);
8033 struct type
*base_type
;
8036 if (raw_type
== NULL
)
8037 base_type
= builtin_type_int
;
8038 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
8039 base_type
= TYPE_TARGET_TYPE (raw_type
);
8041 base_type
= raw_type
;
8043 subtype_info
= strstr (name
, "___XD");
8044 if (subtype_info
== NULL
)
8048 static char *name_buf
= NULL
;
8049 static size_t name_len
= 0;
8050 int prefix_len
= subtype_info
- name
;
8056 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
8057 strncpy (name_buf
, name
, prefix_len
);
8058 name_buf
[prefix_len
] = '\0';
8061 bounds_str
= strchr (subtype_info
, '_');
8064 if (*subtype_info
== 'L')
8066 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
8067 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
8069 if (bounds_str
[n
] == '_')
8071 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
8078 strcpy (name_buf
+ prefix_len
, "___L");
8079 L
= get_int_var_value (name_buf
, &ok
);
8082 lim_warning ("Unknown lower bound, using 1.", 1);
8087 if (*subtype_info
== 'U')
8089 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
8090 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
8096 strcpy (name_buf
+ prefix_len
, "___U");
8097 U
= get_int_var_value (name_buf
, &ok
);
8100 lim_warning ("Unknown upper bound, using %ld.", (long) L
);
8105 if (objfile
== NULL
)
8106 objfile
= TYPE_OBJFILE (base_type
);
8107 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
8108 TYPE_NAME (type
) = name
;
8113 /* True iff NAME is the name of a range type. */
8116 ada_is_range_type_name (const char *name
)
8118 return (name
!= NULL
&& strstr (name
, "___XD"));
8124 /* True iff TYPE is an Ada modular type. */
8127 ada_is_modular_type (struct type
*type
)
8129 struct type
*subranged_type
= base_type (type
);
8131 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
8132 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
8133 && TYPE_UNSIGNED (subranged_type
));
8136 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8139 ada_modulus (struct type
* type
)
8141 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
8145 /* Information about operators given special treatment in functions
8147 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
8149 #define ADA_OPERATORS \
8150 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
8151 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
8152 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
8153 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
8154 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
8155 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
8156 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
8157 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
8158 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
8159 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
8160 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
8161 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
8162 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
8163 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
8164 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
8165 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
8168 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
8170 switch (exp
->elts
[pc
- 1].opcode
)
8173 operator_length_standard (exp
, pc
, oplenp
, argsp
);
8176 #define OP_DEFN(op, len, args, binop) \
8177 case op: *oplenp = len; *argsp = args; break;
8184 ada_op_name (enum exp_opcode opcode
)
8189 return op_name_standard (opcode
);
8190 #define OP_DEFN(op, len, args, binop) case op: return #op;
8196 /* As for operator_length, but assumes PC is pointing at the first
8197 element of the operator, and gives meaningful results only for the
8198 Ada-specific operators. */
8201 ada_forward_operator_length (struct expression
*exp
, int pc
,
8202 int *oplenp
, int *argsp
)
8204 switch (exp
->elts
[pc
].opcode
)
8207 *oplenp
= *argsp
= 0;
8209 #define OP_DEFN(op, len, args, binop) \
8210 case op: *oplenp = len; *argsp = args; break;
8217 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
8219 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
8224 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
8228 /* Ada attributes ('Foo). */
8235 case OP_ATR_MODULUS
:
8244 fprintf_filtered (stream
, "Type @");
8245 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
8246 fprintf_filtered (stream
, " (");
8247 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
8248 fprintf_filtered (stream
, ")");
8250 case BINOP_IN_BOUNDS
:
8251 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
8253 case TERNOP_IN_RANGE
:
8257 return dump_subexp_body_standard (exp
, stream
, elt
);
8261 for (i
= 0; i
< nargs
; i
+= 1)
8262 elt
= dump_subexp (exp
, stream
, elt
);
8267 /* The Ada extension of print_subexp (q.v.). */
8270 ada_print_subexp (struct expression
*exp
, int *pos
,
8271 struct ui_file
*stream
, enum precedence prec
)
8275 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
8277 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8282 print_subexp_standard (exp
, pos
, stream
, prec
);
8287 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
8290 case BINOP_IN_BOUNDS
:
8292 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8293 fputs_filtered (" in ", stream
);
8294 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8295 fputs_filtered ("'range", stream
);
8296 if (exp
->elts
[pc
+ 1].longconst
> 1)
8297 fprintf_filtered (stream
, "(%ld)",
8298 (long) exp
->elts
[pc
+ 1].longconst
);
8301 case TERNOP_IN_RANGE
:
8303 if (prec
>= PREC_EQUAL
)
8304 fputs_filtered ("(", stream
);
8305 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8306 fputs_filtered (" in ", stream
);
8307 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8308 fputs_filtered (" .. ", stream
);
8309 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8310 if (prec
>= PREC_EQUAL
)
8311 fputs_filtered (")", stream
);
8320 case OP_ATR_MODULUS
:
8326 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8328 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
8329 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
8333 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8334 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
8338 for (tem
= 1; tem
< nargs
; tem
+= 1)
8340 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
8341 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
8343 fputs_filtered (")", stream
);
8349 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
8350 fputs_filtered ("'(", stream
);
8351 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
8352 fputs_filtered (")", stream
);
8357 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8358 fputs_filtered (" in ", stream
);
8359 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
8364 /* Table mapping opcodes into strings for printing operators
8365 and precedences of the operators. */
8367 static const struct op_print ada_op_print_tab
[] = {
8368 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
8369 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
8370 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
8371 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
8372 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
8373 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
8374 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
8375 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
8376 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
8377 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
8378 {">", BINOP_GTR
, PREC_ORDER
, 0},
8379 {"<", BINOP_LESS
, PREC_ORDER
, 0},
8380 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
8381 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
8382 {"+", BINOP_ADD
, PREC_ADD
, 0},
8383 {"-", BINOP_SUB
, PREC_ADD
, 0},
8384 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8385 {"*", BINOP_MUL
, PREC_MUL
, 0},
8386 {"/", BINOP_DIV
, PREC_MUL
, 0},
8387 {"rem", BINOP_REM
, PREC_MUL
, 0},
8388 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8389 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8390 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8391 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8392 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8393 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8394 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8395 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8396 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
8397 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
8398 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
8402 /* Fundamental Ada Types */
8404 /* Create a fundamental Ada type using default reasonable for the current
8407 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8408 define fundamental types such as "int" or "double". Others (stabs or
8409 DWARF version 2, etc) do define fundamental types. For the formats which
8410 don't provide fundamental types, gdb can create such types using this
8413 FIXME: Some compilers distinguish explicitly signed integral types
8414 (signed short, signed int, signed long) from "regular" integral types
8415 (short, int, long) in the debugging information. There is some dis-
8416 agreement as to how useful this feature is. In particular, gcc does
8417 not support this. Also, only some debugging formats allow the
8418 distinction to be passed on to a debugger. For now, we always just
8419 use "short", "int", or "long" as the type name, for both the implicit
8420 and explicitly signed types. This also makes life easier for the
8421 gdb test suite since we don't have to account for the differences
8422 in output depending upon what the compiler and debugging format
8423 support. We will probably have to re-examine the issue when gdb
8424 starts taking it's fundamental type information directly from the
8425 debugging information supplied by the compiler. fnf@cygnus.com */
8427 static struct type
*
8428 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8430 struct type
*type
= NULL
;
8435 /* FIXME: For now, if we are asked to produce a type not in this
8436 language, create the equivalent of a C integer type with the
8437 name "<?type?>". When all the dust settles from the type
8438 reconstruction work, this should probably become an error. */
8439 type
= init_type (TYPE_CODE_INT
,
8440 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8441 0, "<?type?>", objfile
);
8442 warning ("internal error: no Ada fundamental type %d", typeid);
8445 type
= init_type (TYPE_CODE_VOID
,
8446 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8447 0, "void", objfile
);
8450 type
= init_type (TYPE_CODE_INT
,
8451 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8452 0, "character", objfile
);
8454 case FT_SIGNED_CHAR
:
8455 type
= init_type (TYPE_CODE_INT
,
8456 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8457 0, "signed char", objfile
);
8459 case FT_UNSIGNED_CHAR
:
8460 type
= init_type (TYPE_CODE_INT
,
8461 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8462 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8465 type
= init_type (TYPE_CODE_INT
,
8466 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8467 0, "short_integer", objfile
);
8469 case FT_SIGNED_SHORT
:
8470 type
= init_type (TYPE_CODE_INT
,
8471 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8472 0, "short_integer", objfile
);
8474 case FT_UNSIGNED_SHORT
:
8475 type
= init_type (TYPE_CODE_INT
,
8476 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8477 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8480 type
= init_type (TYPE_CODE_INT
,
8481 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8482 0, "integer", objfile
);
8484 case FT_SIGNED_INTEGER
:
8485 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/
8487 0, "integer", objfile
); /* FIXME -fnf */
8489 case FT_UNSIGNED_INTEGER
:
8490 type
= init_type (TYPE_CODE_INT
,
8491 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8492 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8495 type
= init_type (TYPE_CODE_INT
,
8496 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8497 0, "long_integer", objfile
);
8499 case FT_SIGNED_LONG
:
8500 type
= init_type (TYPE_CODE_INT
,
8501 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8502 0, "long_integer", objfile
);
8504 case FT_UNSIGNED_LONG
:
8505 type
= init_type (TYPE_CODE_INT
,
8506 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8507 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8510 type
= init_type (TYPE_CODE_INT
,
8511 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8512 0, "long_long_integer", objfile
);
8514 case FT_SIGNED_LONG_LONG
:
8515 type
= init_type (TYPE_CODE_INT
,
8516 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8517 0, "long_long_integer", objfile
);
8519 case FT_UNSIGNED_LONG_LONG
:
8520 type
= init_type (TYPE_CODE_INT
,
8521 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8522 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8525 type
= init_type (TYPE_CODE_FLT
,
8526 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8527 0, "float", objfile
);
8529 case FT_DBL_PREC_FLOAT
:
8530 type
= init_type (TYPE_CODE_FLT
,
8531 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8532 0, "long_float", objfile
);
8534 case FT_EXT_PREC_FLOAT
:
8535 type
= init_type (TYPE_CODE_FLT
,
8536 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8537 0, "long_long_float", objfile
);
8543 enum ada_primitive_types
{
8544 ada_primitive_type_int
,
8545 ada_primitive_type_long
,
8546 ada_primitive_type_short
,
8547 ada_primitive_type_char
,
8548 ada_primitive_type_float
,
8549 ada_primitive_type_double
,
8550 ada_primitive_type_void
,
8551 ada_primitive_type_long_long
,
8552 ada_primitive_type_long_double
,
8553 ada_primitive_type_natural
,
8554 ada_primitive_type_positive
,
8555 ada_primitive_type_system_address
,
8556 nr_ada_primitive_types
8560 ada_language_arch_info (struct gdbarch
*current_gdbarch
,
8561 struct language_arch_info
*lai
)
8563 const struct builtin_type
*builtin
= builtin_type (current_gdbarch
);
8564 lai
->primitive_type_vector
8565 = GDBARCH_OBSTACK_CALLOC (current_gdbarch
, nr_ada_primitive_types
+ 1,
8567 lai
->primitive_type_vector
[ada_primitive_type_int
] =
8568 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8569 0, "integer", (struct objfile
*) NULL
);
8570 lai
->primitive_type_vector
[ada_primitive_type_long
] =
8571 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8572 0, "long_integer", (struct objfile
*) NULL
);
8573 lai
->primitive_type_vector
[ada_primitive_type_short
] =
8574 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8575 0, "short_integer", (struct objfile
*) NULL
);
8576 lai
->string_char_type
=
8577 lai
->primitive_type_vector
[ada_primitive_type_char
] =
8578 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8579 0, "character", (struct objfile
*) NULL
);
8580 lai
->primitive_type_vector
[ada_primitive_type_float
] =
8581 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8582 0, "float", (struct objfile
*) NULL
);
8583 lai
->primitive_type_vector
[ada_primitive_type_double
] =
8584 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8585 0, "long_float", (struct objfile
*) NULL
);
8586 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
8587 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8588 0, "long_long_integer", (struct objfile
*) NULL
);
8589 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
8590 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8591 0, "long_long_float", (struct objfile
*) NULL
);
8592 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
8593 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8594 0, "natural", (struct objfile
*) NULL
);
8595 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
8596 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8597 0, "positive", (struct objfile
*) NULL
);
8598 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
8600 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
8601 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8602 (struct objfile
*) NULL
));
8603 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
8604 = "system__address";
8607 /* Language vector */
8609 /* Not really used, but needed in the ada_language_defn. */
8612 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8614 ada_emit_char (c
, stream
, quoter
, 1);
8620 warnings_issued
= 0;
8621 return ada_parse ();
8624 static const struct exp_descriptor ada_exp_descriptor
= {
8626 ada_operator_length
,
8628 ada_dump_subexp_body
,
8632 const struct language_defn ada_language_defn
= {
8633 "ada", /* Language name */
8638 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8639 that's not quite what this means. */
8641 &ada_exp_descriptor
,
8645 ada_printchar
, /* Print a character constant */
8646 ada_printstr
, /* Function to print string constant */
8647 emit_char
, /* Function to print single char (not used) */
8648 ada_create_fundamental_type
, /* Create fundamental type in this language */
8649 ada_print_type
, /* Print a type using appropriate syntax */
8650 ada_val_print
, /* Print a value using appropriate syntax */
8651 ada_value_print
, /* Print a top-level value */
8652 NULL
, /* Language specific skip_trampoline */
8653 NULL
, /* value_of_this */
8654 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
8655 basic_lookup_transparent_type
, /* lookup_transparent_type */
8656 ada_la_decode
, /* Language specific symbol demangler */
8657 NULL
, /* Language specific class_name_from_physname */
8658 ada_op_print_tab
, /* expression operators for printing */
8659 0, /* c-style arrays */
8660 1, /* String lower bound */
8662 ada_get_gdb_completer_word_break_characters
,
8663 ada_language_arch_info
,
8668 _initialize_ada_language (void)
8670 add_language (&ada_language_defn
);
8672 varsize_limit
= 65536;
8674 obstack_init (&symbol_list_obstack
);
8676 decoded_names_store
= htab_create_alloc
8677 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
8678 NULL
, xcalloc
, xfree
);