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
482 lim_warning (const char *format
, ...)
485 va_start (args
, format
);
487 warnings_issued
+= 1;
488 if (warnings_issued
<= warning_limit
)
489 vwarning (format
, args
);
494 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
495 gdbtypes.h, but some of the necessary definitions in that file
496 seem to have gone missing. */
498 /* Maximum value of a SIZE-byte signed integer type. */
500 max_of_size (int size
)
502 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
503 return top_bit
| (top_bit
- 1);
506 /* Minimum value of a SIZE-byte signed integer type. */
508 min_of_size (int size
)
510 return -max_of_size (size
) - 1;
513 /* Maximum value of a SIZE-byte unsigned integer type. */
515 umax_of_size (int size
)
517 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
518 return top_bit
| (top_bit
- 1);
521 /* Maximum value of integral type T, as a signed quantity. */
523 max_of_type (struct type
*t
)
525 if (TYPE_UNSIGNED (t
))
526 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
528 return max_of_size (TYPE_LENGTH (t
));
531 /* Minimum value of integral type T, as a signed quantity. */
533 min_of_type (struct type
*t
)
535 if (TYPE_UNSIGNED (t
))
538 return min_of_size (TYPE_LENGTH (t
));
541 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
542 static struct value
*
543 discrete_type_high_bound (struct type
*type
)
545 switch (TYPE_CODE (type
))
547 case TYPE_CODE_RANGE
:
548 return value_from_longest (TYPE_TARGET_TYPE (type
),
549 TYPE_HIGH_BOUND (type
));
552 value_from_longest (type
,
553 TYPE_FIELD_BITPOS (type
,
554 TYPE_NFIELDS (type
) - 1));
556 return value_from_longest (type
, max_of_type (type
));
558 error ("Unexpected type in discrete_type_high_bound.");
562 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
563 static struct value
*
564 discrete_type_low_bound (struct type
*type
)
566 switch (TYPE_CODE (type
))
568 case TYPE_CODE_RANGE
:
569 return value_from_longest (TYPE_TARGET_TYPE (type
),
570 TYPE_LOW_BOUND (type
));
572 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
574 return value_from_longest (type
, min_of_type (type
));
576 error ("Unexpected type in discrete_type_low_bound.");
580 /* The identity on non-range types. For range types, the underlying
581 non-range scalar type. */
584 base_type (struct type
*type
)
586 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
588 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
590 type
= TYPE_TARGET_TYPE (type
);
596 /* Language Selection */
598 /* If the main program is in Ada, return language_ada, otherwise return LANG
599 (the main program is in Ada iif the adainit symbol is found).
601 MAIN_PST is not used. */
604 ada_update_initial_language (enum language lang
,
605 struct partial_symtab
*main_pst
)
607 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
608 (struct objfile
*) NULL
) != NULL
)
614 /* If the main procedure is written in Ada, then return its name.
615 The result is good until the next call. Return NULL if the main
616 procedure doesn't appear to be in Ada. */
621 struct minimal_symbol
*msym
;
622 CORE_ADDR main_program_name_addr
;
623 static char main_program_name
[1024];
625 /* For Ada, the name of the main procedure is stored in a specific
626 string constant, generated by the binder. Look for that symbol,
627 extract its address, and then read that string. If we didn't find
628 that string, then most probably the main procedure is not written
630 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
634 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
635 if (main_program_name_addr
== 0)
636 error ("Invalid address for Ada main program name.");
638 extract_string (main_program_name_addr
, main_program_name
);
639 return main_program_name
;
642 /* The main procedure doesn't seem to be in Ada. */
648 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
651 const struct ada_opname_map ada_opname_table
[] = {
652 {"Oadd", "\"+\"", BINOP_ADD
},
653 {"Osubtract", "\"-\"", BINOP_SUB
},
654 {"Omultiply", "\"*\"", BINOP_MUL
},
655 {"Odivide", "\"/\"", BINOP_DIV
},
656 {"Omod", "\"mod\"", BINOP_MOD
},
657 {"Orem", "\"rem\"", BINOP_REM
},
658 {"Oexpon", "\"**\"", BINOP_EXP
},
659 {"Olt", "\"<\"", BINOP_LESS
},
660 {"Ole", "\"<=\"", BINOP_LEQ
},
661 {"Ogt", "\">\"", BINOP_GTR
},
662 {"Oge", "\">=\"", BINOP_GEQ
},
663 {"Oeq", "\"=\"", BINOP_EQUAL
},
664 {"One", "\"/=\"", BINOP_NOTEQUAL
},
665 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
666 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
667 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
668 {"Oconcat", "\"&\"", BINOP_CONCAT
},
669 {"Oabs", "\"abs\"", UNOP_ABS
},
670 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
671 {"Oadd", "\"+\"", UNOP_PLUS
},
672 {"Osubtract", "\"-\"", UNOP_NEG
},
676 /* Return non-zero if STR should be suppressed in info listings. */
679 is_suppressed_name (const char *str
)
681 if (strncmp (str
, "_ada_", 5) == 0)
683 if (str
[0] == '_' || str
[0] == '\000')
688 const char *suffix
= strstr (str
, "___");
689 if (suffix
!= NULL
&& suffix
[3] != 'X')
692 suffix
= str
+ strlen (str
);
693 for (p
= suffix
- 1; p
!= str
; p
-= 1)
697 if (p
[0] == 'X' && p
[-1] != '_')
701 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
702 if (strncmp (ada_opname_table
[i
].encoded
, p
,
703 strlen (ada_opname_table
[i
].encoded
)) == 0)
712 /* The "encoded" form of DECODED, according to GNAT conventions.
713 The result is valid until the next call to ada_encode. */
716 ada_encode (const char *decoded
)
718 static char *encoding_buffer
= NULL
;
719 static size_t encoding_buffer_size
= 0;
726 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
727 2 * strlen (decoded
) + 10);
730 for (p
= decoded
; *p
!= '\0'; p
+= 1)
732 if (!ADA_RETAIN_DOTS
&& *p
== '.')
734 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
739 const struct ada_opname_map
*mapping
;
741 for (mapping
= ada_opname_table
;
742 mapping
->encoded
!= NULL
743 && strncmp (mapping
->decoded
, p
,
744 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
746 if (mapping
->encoded
== NULL
)
747 error ("invalid Ada operator name: %s", p
);
748 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
749 k
+= strlen (mapping
->encoded
);
754 encoding_buffer
[k
] = *p
;
759 encoding_buffer
[k
] = '\0';
760 return encoding_buffer
;
763 /* Return NAME folded to lower case, or, if surrounded by single
764 quotes, unfolded, but with the quotes stripped away. Result good
768 ada_fold_name (const char *name
)
770 static char *fold_buffer
= NULL
;
771 static size_t fold_buffer_size
= 0;
773 int len
= strlen (name
);
774 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
778 strncpy (fold_buffer
, name
+ 1, len
- 2);
779 fold_buffer
[len
- 2] = '\000';
784 for (i
= 0; i
<= len
; i
+= 1)
785 fold_buffer
[i
] = tolower (name
[i
]);
792 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
793 These are suffixes introduced by GNAT5 to nested subprogram
794 names, and do not serve any purpose for the debugger.
795 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
796 2. Convert other instances of embedded "__" to `.'.
797 3. Discard leading _ada_.
798 4. Convert operator names to the appropriate quoted symbols.
799 5. Remove everything after first ___ if it is followed by
801 6. Replace TK__ with __, and a trailing B or TKB with nothing.
802 7. Put symbols that should be suppressed in <...> brackets.
803 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
805 The resulting string is valid until the next call of ada_decode.
806 If the string is unchanged by demangling, the original string pointer
810 ada_decode (const char *encoded
)
817 static char *decoding_buffer
= NULL
;
818 static size_t decoding_buffer_size
= 0;
820 if (strncmp (encoded
, "_ada_", 5) == 0)
823 if (encoded
[0] == '_' || encoded
[0] == '<')
826 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
827 len0
= strlen (encoded
);
828 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
831 while (i
> 0 && isdigit (encoded
[i
]))
833 if (i
>= 0 && encoded
[i
] == '.')
835 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
839 /* Remove the ___X.* suffix if present. Do not forget to verify that
840 the suffix is located before the current "end" of ENCODED. We want
841 to avoid re-matching parts of ENCODED that have previously been
842 marked as discarded (by decrementing LEN0). */
843 p
= strstr (encoded
, "___");
844 if (p
!= NULL
&& p
- encoded
< len0
- 3)
852 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
855 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
858 /* Make decoded big enough for possible expansion by operator name. */
859 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
860 decoded
= decoding_buffer
;
862 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
865 while ((i
>= 0 && isdigit (encoded
[i
]))
866 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
868 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
870 else if (encoded
[i
] == '$')
874 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
875 decoded
[j
] = encoded
[i
];
880 if (at_start_name
&& encoded
[i
] == 'O')
883 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
885 int op_len
= strlen (ada_opname_table
[k
].encoded
);
886 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
888 && !isalnum (encoded
[i
+ op_len
]))
890 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
893 j
+= strlen (ada_opname_table
[k
].decoded
);
897 if (ada_opname_table
[k
].encoded
!= NULL
)
902 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
904 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
908 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
912 else if (!ADA_RETAIN_DOTS
913 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
922 decoded
[j
] = encoded
[i
];
929 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
930 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
933 if (strcmp (decoded
, encoded
) == 0)
939 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
940 decoded
= decoding_buffer
;
941 if (encoded
[0] == '<')
942 strcpy (decoded
, encoded
);
944 sprintf (decoded
, "<%s>", encoded
);
949 /* Table for keeping permanent unique copies of decoded names. Once
950 allocated, names in this table are never released. While this is a
951 storage leak, it should not be significant unless there are massive
952 changes in the set of decoded names in successive versions of a
953 symbol table loaded during a single session. */
954 static struct htab
*decoded_names_store
;
956 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
957 in the language-specific part of GSYMBOL, if it has not been
958 previously computed. Tries to save the decoded name in the same
959 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
960 in any case, the decoded symbol has a lifetime at least that of
962 The GSYMBOL parameter is "mutable" in the C++ sense: logically
963 const, but nevertheless modified to a semantically equivalent form
964 when a decoded name is cached in it.
968 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
971 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
972 if (*resultp
== NULL
)
974 const char *decoded
= ada_decode (gsymbol
->name
);
975 if (gsymbol
->bfd_section
!= NULL
)
977 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
980 struct objfile
*objf
;
983 if (obfd
== objf
->obfd
)
985 *resultp
= obsavestring (decoded
, strlen (decoded
),
986 &objf
->objfile_obstack
);
992 /* Sometimes, we can't find a corresponding objfile, in which
993 case, we put the result on the heap. Since we only decode
994 when needed, we hope this usually does not cause a
995 significant memory leak (FIXME). */
996 if (*resultp
== NULL
)
998 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1001 *slot
= xstrdup (decoded
);
1010 ada_la_decode (const char *encoded
, int options
)
1012 return xstrdup (ada_decode (encoded
));
1015 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1016 suffixes that encode debugging information or leading _ada_ on
1017 SYM_NAME (see is_name_suffix commentary for the debugging
1018 information that is ignored). If WILD, then NAME need only match a
1019 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1020 either argument is NULL. */
1023 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1025 if (sym_name
== NULL
|| name
== NULL
)
1028 return wild_match (name
, strlen (name
), sym_name
);
1031 int len_name
= strlen (name
);
1032 return (strncmp (sym_name
, name
, len_name
) == 0
1033 && is_name_suffix (sym_name
+ len_name
))
1034 || (strncmp (sym_name
, "_ada_", 5) == 0
1035 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1036 && is_name_suffix (sym_name
+ len_name
+ 5));
1040 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1041 suppressed in info listings. */
1044 ada_suppress_symbol_printing (struct symbol
*sym
)
1046 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1049 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1055 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1057 static char *bound_name
[] = {
1058 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1059 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1062 /* Maximum number of array dimensions we are prepared to handle. */
1064 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1066 /* Like modify_field, but allows bitpos > wordlength. */
1069 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1071 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1075 /* The desc_* routines return primitive portions of array descriptors
1078 /* The descriptor or array type, if any, indicated by TYPE; removes
1079 level of indirection, if needed. */
1081 static struct type
*
1082 desc_base_type (struct type
*type
)
1086 type
= ada_check_typedef (type
);
1088 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1089 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1090 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1095 /* True iff TYPE indicates a "thin" array pointer type. */
1098 is_thin_pntr (struct type
*type
)
1101 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1102 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1105 /* The descriptor type for thin pointer type TYPE. */
1107 static struct type
*
1108 thin_descriptor_type (struct type
*type
)
1110 struct type
*base_type
= desc_base_type (type
);
1111 if (base_type
== NULL
)
1113 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1117 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1118 if (alt_type
== NULL
)
1125 /* A pointer to the array data for thin-pointer value VAL. */
1127 static struct value
*
1128 thin_data_pntr (struct value
*val
)
1130 struct type
*type
= VALUE_TYPE (val
);
1131 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1132 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1135 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1136 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
1139 /* True iff TYPE indicates a "thick" array pointer type. */
1142 is_thick_pntr (struct type
*type
)
1144 type
= desc_base_type (type
);
1145 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1146 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1149 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1150 pointer to one, the type of its bounds data; otherwise, NULL. */
1152 static struct type
*
1153 desc_bounds_type (struct type
*type
)
1157 type
= desc_base_type (type
);
1161 else if (is_thin_pntr (type
))
1163 type
= thin_descriptor_type (type
);
1166 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1168 return ada_check_typedef (r
);
1170 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1172 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1174 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1179 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1180 one, a pointer to its bounds data. Otherwise NULL. */
1182 static struct value
*
1183 desc_bounds (struct value
*arr
)
1185 struct type
*type
= ada_check_typedef (VALUE_TYPE (arr
));
1186 if (is_thin_pntr (type
))
1188 struct type
*bounds_type
=
1189 desc_bounds_type (thin_descriptor_type (type
));
1192 if (desc_bounds_type
== NULL
)
1193 error ("Bad GNAT array descriptor");
1195 /* NOTE: The following calculation is not really kosher, but
1196 since desc_type is an XVE-encoded type (and shouldn't be),
1197 the correct calculation is a real pain. FIXME (and fix GCC). */
1198 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1199 addr
= value_as_long (arr
);
1201 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
1204 value_from_longest (lookup_pointer_type (bounds_type
),
1205 addr
- TYPE_LENGTH (bounds_type
));
1208 else if (is_thick_pntr (type
))
1209 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1210 "Bad GNAT array descriptor");
1215 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1216 position of the field containing the address of the bounds data. */
1219 fat_pntr_bounds_bitpos (struct type
*type
)
1221 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1224 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1225 size of the field containing the address of the bounds data. */
1228 fat_pntr_bounds_bitsize (struct type
*type
)
1230 type
= desc_base_type (type
);
1232 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1233 return TYPE_FIELD_BITSIZE (type
, 1);
1235 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1238 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1239 pointer to one, the type of its array data (a
1240 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1241 ada_type_of_array to get an array type with bounds data. */
1243 static struct type
*
1244 desc_data_type (struct type
*type
)
1246 type
= desc_base_type (type
);
1248 /* NOTE: The following is bogus; see comment in desc_bounds. */
1249 if (is_thin_pntr (type
))
1250 return lookup_pointer_type
1251 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1252 else if (is_thick_pntr (type
))
1253 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1258 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1261 static struct value
*
1262 desc_data (struct value
*arr
)
1264 struct type
*type
= VALUE_TYPE (arr
);
1265 if (is_thin_pntr (type
))
1266 return thin_data_pntr (arr
);
1267 else if (is_thick_pntr (type
))
1268 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1269 "Bad GNAT array descriptor");
1275 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1276 position of the field containing the address of the data. */
1279 fat_pntr_data_bitpos (struct type
*type
)
1281 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1284 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1285 size of the field containing the address of the data. */
1288 fat_pntr_data_bitsize (struct type
*type
)
1290 type
= desc_base_type (type
);
1292 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1293 return TYPE_FIELD_BITSIZE (type
, 0);
1295 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1298 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1299 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1300 bound, if WHICH is 1. The first bound is I=1. */
1302 static struct value
*
1303 desc_one_bound (struct value
*bounds
, int i
, int which
)
1305 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1306 "Bad GNAT array descriptor bounds");
1309 /* If BOUNDS is an array-bounds structure type, return the bit position
1310 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1311 bound, if WHICH is 1. The first bound is I=1. */
1314 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1316 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1319 /* If BOUNDS is an array-bounds structure type, return the bit field size
1320 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1321 bound, if WHICH is 1. The first bound is I=1. */
1324 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1326 type
= desc_base_type (type
);
1328 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1329 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1331 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1334 /* If TYPE is the type of an array-bounds structure, the type of its
1335 Ith bound (numbering from 1). Otherwise, NULL. */
1337 static struct type
*
1338 desc_index_type (struct type
*type
, int i
)
1340 type
= desc_base_type (type
);
1342 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1343 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1348 /* The number of index positions in the array-bounds type TYPE.
1349 Return 0 if TYPE is NULL. */
1352 desc_arity (struct type
*type
)
1354 type
= desc_base_type (type
);
1357 return TYPE_NFIELDS (type
) / 2;
1361 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1362 an array descriptor type (representing an unconstrained array
1366 ada_is_direct_array_type (struct type
*type
)
1370 type
= ada_check_typedef (type
);
1371 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1372 || ada_is_array_descriptor_type (type
));
1375 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1378 ada_is_simple_array_type (struct type
*type
)
1382 type
= ada_check_typedef (type
);
1383 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1384 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1385 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1388 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1391 ada_is_array_descriptor_type (struct type
*type
)
1393 struct type
*data_type
= desc_data_type (type
);
1397 type
= ada_check_typedef (type
);
1400 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1401 && TYPE_TARGET_TYPE (data_type
) != NULL
1402 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1403 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1404 && desc_arity (desc_bounds_type (type
)) > 0;
1407 /* Non-zero iff type is a partially mal-formed GNAT array
1408 descriptor. FIXME: This is to compensate for some problems with
1409 debugging output from GNAT. Re-examine periodically to see if it
1413 ada_is_bogus_array_descriptor (struct type
*type
)
1417 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1418 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1419 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1420 && !ada_is_array_descriptor_type (type
);
1424 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1425 (fat pointer) returns the type of the array data described---specifically,
1426 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1427 in from the descriptor; otherwise, they are left unspecified. If
1428 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1429 returns NULL. The result is simply the type of ARR if ARR is not
1432 ada_type_of_array (struct value
*arr
, int bounds
)
1434 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1435 return decode_packed_array_type (VALUE_TYPE (arr
));
1437 if (!ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1438 return VALUE_TYPE (arr
);
1442 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1445 struct type
*elt_type
;
1447 struct value
*descriptor
;
1448 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1450 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1451 arity
= ada_array_arity (VALUE_TYPE (arr
));
1453 if (elt_type
== NULL
|| arity
== 0)
1454 return ada_check_typedef (VALUE_TYPE (arr
));
1456 descriptor
= desc_bounds (arr
);
1457 if (value_as_long (descriptor
) == 0)
1461 struct type
*range_type
= alloc_type (objf
);
1462 struct type
*array_type
= alloc_type (objf
);
1463 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1464 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1467 create_range_type (range_type
, VALUE_TYPE (low
),
1468 (int) value_as_long (low
),
1469 (int) value_as_long (high
));
1470 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1473 return lookup_pointer_type (elt_type
);
1477 /* If ARR does not represent an array, returns ARR unchanged.
1478 Otherwise, returns either a standard GDB array with bounds set
1479 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1480 GDB array. Returns NULL if ARR is a null fat pointer. */
1483 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1485 if (ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1487 struct type
*arrType
= ada_type_of_array (arr
, 1);
1488 if (arrType
== NULL
)
1490 return value_cast (arrType
, value_copy (desc_data (arr
)));
1492 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1493 return decode_packed_array (arr
);
1498 /* If ARR does not represent an array, returns ARR unchanged.
1499 Otherwise, returns a standard GDB array describing ARR (which may
1500 be ARR itself if it already is in the proper form). */
1502 static struct value
*
1503 ada_coerce_to_simple_array (struct value
*arr
)
1505 if (ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1507 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1509 error ("Bounds unavailable for null array pointer.");
1510 return value_ind (arrVal
);
1512 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1513 return decode_packed_array (arr
);
1518 /* If TYPE represents a GNAT array type, return it translated to an
1519 ordinary GDB array type (possibly with BITSIZE fields indicating
1520 packing). For other types, is the identity. */
1523 ada_coerce_to_simple_array_type (struct type
*type
)
1525 struct value
*mark
= value_mark ();
1526 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1527 struct type
*result
;
1528 VALUE_TYPE (dummy
) = type
;
1529 result
= ada_type_of_array (dummy
, 0);
1530 value_free_to_mark (mark
);
1534 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1537 ada_is_packed_array_type (struct type
*type
)
1541 type
= desc_base_type (type
);
1542 type
= ada_check_typedef (type
);
1544 ada_type_name (type
) != NULL
1545 && strstr (ada_type_name (type
), "___XP") != NULL
;
1548 /* Given that TYPE is a standard GDB array type with all bounds filled
1549 in, and that the element size of its ultimate scalar constituents
1550 (that is, either its elements, or, if it is an array of arrays, its
1551 elements' elements, etc.) is *ELT_BITS, return an identical type,
1552 but with the bit sizes of its elements (and those of any
1553 constituent arrays) recorded in the BITSIZE components of its
1554 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1557 static struct type
*
1558 packed_array_type (struct type
*type
, long *elt_bits
)
1560 struct type
*new_elt_type
;
1561 struct type
*new_type
;
1562 LONGEST low_bound
, high_bound
;
1564 type
= ada_check_typedef (type
);
1565 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1568 new_type
= alloc_type (TYPE_OBJFILE (type
));
1569 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1571 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1572 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1573 TYPE_NAME (new_type
) = ada_type_name (type
);
1575 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1576 &low_bound
, &high_bound
) < 0)
1577 low_bound
= high_bound
= 0;
1578 if (high_bound
< low_bound
)
1579 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1582 *elt_bits
*= (high_bound
- low_bound
+ 1);
1583 TYPE_LENGTH (new_type
) =
1584 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1587 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1591 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1593 static struct type
*
1594 decode_packed_array_type (struct type
*type
)
1597 struct block
**blocks
;
1598 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
1599 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1600 char *tail
= strstr (raw_name
, "___XP");
1601 struct type
*shadow_type
;
1605 type
= desc_base_type (type
);
1607 memcpy (name
, raw_name
, tail
- raw_name
);
1608 name
[tail
- raw_name
] = '\000';
1610 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1611 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1613 lim_warning ("could not find bounds information on packed array");
1616 shadow_type
= SYMBOL_TYPE (sym
);
1618 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1620 lim_warning ("could not understand bounds information on packed array");
1624 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1627 ("could not understand bit size information on packed array");
1631 return packed_array_type (shadow_type
, &bits
);
1634 /* Given that ARR is a struct value *indicating a GNAT packed array,
1635 returns a simple array that denotes that array. Its type is a
1636 standard GDB array type except that the BITSIZEs of the array
1637 target types are set to the number of bits in each element, and the
1638 type length is set appropriately. */
1640 static struct value
*
1641 decode_packed_array (struct value
*arr
)
1645 arr
= ada_coerce_ref (arr
);
1646 if (TYPE_CODE (VALUE_TYPE (arr
)) == TYPE_CODE_PTR
)
1647 arr
= ada_value_ind (arr
);
1649 type
= decode_packed_array_type (VALUE_TYPE (arr
));
1652 error ("can't unpack array");
1656 if (BITS_BIG_ENDIAN
&& ada_is_modular_type (VALUE_TYPE (arr
)))
1658 /* This is a (right-justified) modular type representing a packed
1659 array with no wrapper. In order to interpret the value through
1660 the (left-justified) packed array type we just built, we must
1661 first left-justify it. */
1662 int bit_size
, bit_pos
;
1665 mod
= ada_modulus (VALUE_TYPE (arr
)) - 1;
1672 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (VALUE_TYPE (arr
)) - bit_size
;
1673 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1674 bit_pos
/ HOST_CHAR_BIT
,
1675 bit_pos
% HOST_CHAR_BIT
,
1680 return coerce_unspec_val_to_type (arr
, type
);
1684 /* The value of the element of packed array ARR at the ARITY indices
1685 given in IND. ARR must be a simple array. */
1687 static struct value
*
1688 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1691 int bits
, elt_off
, bit_off
;
1692 long elt_total_bit_offset
;
1693 struct type
*elt_type
;
1697 elt_total_bit_offset
= 0;
1698 elt_type
= ada_check_typedef (VALUE_TYPE (arr
));
1699 for (i
= 0; i
< arity
; i
+= 1)
1701 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1702 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1704 ("attempt to do packed indexing of something other than a packed array");
1707 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1708 LONGEST lowerbound
, upperbound
;
1711 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1713 lim_warning ("don't know bounds of array");
1714 lowerbound
= upperbound
= 0;
1717 idx
= value_as_long (value_pos_atr (ind
[i
]));
1718 if (idx
< lowerbound
|| idx
> upperbound
)
1719 lim_warning ("packed array index %ld out of bounds", (long) idx
);
1720 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1721 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1722 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1725 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1726 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1728 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1730 if (VALUE_LVAL (arr
) == lval_internalvar
)
1731 VALUE_LVAL (v
) = lval_internalvar_component
;
1733 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1737 /* Non-zero iff TYPE includes negative integer values. */
1740 has_negatives (struct type
*type
)
1742 switch (TYPE_CODE (type
))
1747 return !TYPE_UNSIGNED (type
);
1748 case TYPE_CODE_RANGE
:
1749 return TYPE_LOW_BOUND (type
) < 0;
1754 /* Create a new value of type TYPE from the contents of OBJ starting
1755 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1756 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1757 assigning through the result will set the field fetched from.
1758 VALADDR is ignored unless OBJ is NULL, in which case,
1759 VALADDR+OFFSET must address the start of storage containing the
1760 packed value. The value returned in this case is never an lval.
1761 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1764 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1765 int bit_offset
, int bit_size
,
1769 int src
, /* Index into the source area */
1770 targ
, /* Index into the target area */
1771 srcBitsLeft
, /* Number of source bits left to move */
1772 nsrc
, ntarg
, /* Number of source and target bytes */
1773 unusedLS
, /* Number of bits in next significant
1774 byte of source that are unused */
1775 accumSize
; /* Number of meaningful bits in accum */
1776 unsigned char *bytes
; /* First byte containing data to unpack */
1777 unsigned char *unpacked
;
1778 unsigned long accum
; /* Staging area for bits being transferred */
1780 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1781 /* Transmit bytes from least to most significant; delta is the direction
1782 the indices move. */
1783 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1785 type
= ada_check_typedef (type
);
1789 v
= allocate_value (type
);
1790 bytes
= (unsigned char *) (valaddr
+ offset
);
1792 else if (VALUE_LAZY (obj
))
1795 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1796 bytes
= (unsigned char *) alloca (len
);
1797 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1801 v
= allocate_value (type
);
1802 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1807 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1808 if (VALUE_LVAL (obj
) == lval_internalvar
)
1809 VALUE_LVAL (v
) = lval_internalvar_component
;
1810 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1811 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1812 VALUE_BITSIZE (v
) = bit_size
;
1813 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1815 VALUE_ADDRESS (v
) += 1;
1816 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1820 VALUE_BITSIZE (v
) = bit_size
;
1821 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1823 srcBitsLeft
= bit_size
;
1825 ntarg
= TYPE_LENGTH (type
);
1829 memset (unpacked
, 0, TYPE_LENGTH (type
));
1832 else if (BITS_BIG_ENDIAN
)
1835 if (has_negatives (type
)
1836 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1840 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1843 switch (TYPE_CODE (type
))
1845 case TYPE_CODE_ARRAY
:
1846 case TYPE_CODE_UNION
:
1847 case TYPE_CODE_STRUCT
:
1848 /* Non-scalar values must be aligned at a byte boundary... */
1850 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1851 /* ... And are placed at the beginning (most-significant) bytes
1857 targ
= TYPE_LENGTH (type
) - 1;
1863 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1866 unusedLS
= bit_offset
;
1869 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1876 /* Mask for removing bits of the next source byte that are not
1877 part of the value. */
1878 unsigned int unusedMSMask
=
1879 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1881 /* Sign-extend bits for this byte. */
1882 unsigned int signMask
= sign
& ~unusedMSMask
;
1884 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1885 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1886 if (accumSize
>= HOST_CHAR_BIT
)
1888 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1889 accumSize
-= HOST_CHAR_BIT
;
1890 accum
>>= HOST_CHAR_BIT
;
1894 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1901 accum
|= sign
<< accumSize
;
1902 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1903 accumSize
-= HOST_CHAR_BIT
;
1904 accum
>>= HOST_CHAR_BIT
;
1912 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1913 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1916 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
1918 unsigned int accum
, mask
;
1919 int accum_bits
, chunk_size
;
1921 target
+= targ_offset
/ HOST_CHAR_BIT
;
1922 targ_offset
%= HOST_CHAR_BIT
;
1923 source
+= src_offset
/ HOST_CHAR_BIT
;
1924 src_offset
%= HOST_CHAR_BIT
;
1925 if (BITS_BIG_ENDIAN
)
1927 accum
= (unsigned char) *source
;
1929 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1934 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1935 accum_bits
+= HOST_CHAR_BIT
;
1937 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1940 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1941 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1944 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1946 accum_bits
-= chunk_size
;
1953 accum
= (unsigned char) *source
>> src_offset
;
1955 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1959 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1960 accum_bits
+= HOST_CHAR_BIT
;
1962 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1965 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1966 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1968 accum_bits
-= chunk_size
;
1969 accum
>>= chunk_size
;
1977 /* Store the contents of FROMVAL into the location of TOVAL.
1978 Return a new value with the location of TOVAL and contents of
1979 FROMVAL. Handles assignment into packed fields that have
1980 floating-point or non-scalar types. */
1982 static struct value
*
1983 ada_value_assign (struct value
*toval
, struct value
*fromval
)
1985 struct type
*type
= VALUE_TYPE (toval
);
1986 int bits
= VALUE_BITSIZE (toval
);
1988 if (!toval
->modifiable
)
1989 error ("Left operand of assignment is not a modifiable lvalue.");
1993 if (VALUE_LVAL (toval
) == lval_memory
1995 && (TYPE_CODE (type
) == TYPE_CODE_FLT
1996 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
1999 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2000 char *buffer
= (char *) alloca (len
);
2003 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2004 fromval
= value_cast (type
, fromval
);
2006 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
2007 if (BITS_BIG_ENDIAN
)
2008 move_bits (buffer
, VALUE_BITPOS (toval
),
2009 VALUE_CONTENTS (fromval
),
2010 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
-
2013 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
2015 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
,
2018 val
= value_copy (toval
);
2019 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
2020 TYPE_LENGTH (type
));
2021 VALUE_TYPE (val
) = type
;
2026 return value_assign (toval
, fromval
);
2030 /* The value of the element of array ARR at the ARITY indices given in IND.
2031 ARR may be either a simple array, GNAT array descriptor, or pointer
2035 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2039 struct type
*elt_type
;
2041 elt
= ada_coerce_to_simple_array (arr
);
2043 elt_type
= ada_check_typedef (VALUE_TYPE (elt
));
2044 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2045 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2046 return value_subscript_packed (elt
, arity
, ind
);
2048 for (k
= 0; k
< arity
; k
+= 1)
2050 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2051 error ("too many subscripts (%d expected)", k
);
2052 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2057 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2058 value of the element of *ARR at the ARITY indices given in
2059 IND. Does not read the entire array into memory. */
2062 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2067 for (k
= 0; k
< arity
; k
+= 1)
2072 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2073 error ("too many subscripts (%d expected)", k
);
2074 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2076 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2077 idx
= value_pos_atr (ind
[k
]);
2079 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2080 arr
= value_add (arr
, idx
);
2081 type
= TYPE_TARGET_TYPE (type
);
2084 return value_ind (arr
);
2087 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2088 actual type of ARRAY_PTR is ignored), returns a reference to
2089 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2090 bound of this array is LOW, as per Ada rules. */
2091 static struct value
*
2092 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2095 CORE_ADDR base
= value_as_address (array_ptr
)
2096 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2097 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2098 struct type
*index_type
=
2099 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2101 struct type
*slice_type
=
2102 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2103 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2107 static struct value
*
2108 ada_value_slice (struct value
*array
, int low
, int high
)
2110 struct type
*type
= VALUE_TYPE (array
);
2111 struct type
*index_type
=
2112 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2113 struct type
*slice_type
=
2114 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2115 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2118 /* If type is a record type in the form of a standard GNAT array
2119 descriptor, returns the number of dimensions for type. If arr is a
2120 simple array, returns the number of "array of"s that prefix its
2121 type designation. Otherwise, returns 0. */
2124 ada_array_arity (struct type
*type
)
2131 type
= desc_base_type (type
);
2134 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2135 return desc_arity (desc_bounds_type (type
));
2137 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2140 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2146 /* If TYPE is a record type in the form of a standard GNAT array
2147 descriptor or a simple array type, returns the element type for
2148 TYPE after indexing by NINDICES indices, or by all indices if
2149 NINDICES is -1. Otherwise, returns NULL. */
2152 ada_array_element_type (struct type
*type
, int nindices
)
2154 type
= desc_base_type (type
);
2156 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2159 struct type
*p_array_type
;
2161 p_array_type
= desc_data_type (type
);
2163 k
= ada_array_arity (type
);
2167 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2168 if (nindices
>= 0 && k
> nindices
)
2170 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2171 while (k
> 0 && p_array_type
!= NULL
)
2173 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2176 return p_array_type
;
2178 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2180 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2182 type
= TYPE_TARGET_TYPE (type
);
2191 /* The type of nth index in arrays of given type (n numbering from 1).
2192 Does not examine memory. */
2195 ada_index_type (struct type
*type
, int n
)
2197 struct type
*result_type
;
2199 type
= desc_base_type (type
);
2201 if (n
> ada_array_arity (type
))
2204 if (ada_is_simple_array_type (type
))
2208 for (i
= 1; i
< n
; i
+= 1)
2209 type
= TYPE_TARGET_TYPE (type
);
2210 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2211 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2212 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2213 perhaps stabsread.c would make more sense. */
2214 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2215 result_type
= builtin_type_int
;
2220 return desc_index_type (desc_bounds_type (type
), n
);
2223 /* Given that arr is an array type, returns the lower bound of the
2224 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2225 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2226 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2227 bounds type. It works for other arrays with bounds supplied by
2228 run-time quantities other than discriminants. */
2231 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2232 struct type
** typep
)
2235 struct type
*index_type_desc
;
2237 if (ada_is_packed_array_type (arr_type
))
2238 arr_type
= decode_packed_array_type (arr_type
);
2240 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2243 *typep
= builtin_type_int
;
2244 return (LONGEST
) - which
;
2247 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2248 type
= TYPE_TARGET_TYPE (arr_type
);
2252 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2253 if (index_type_desc
== NULL
)
2255 struct type
*range_type
;
2256 struct type
*index_type
;
2260 type
= TYPE_TARGET_TYPE (type
);
2264 range_type
= TYPE_INDEX_TYPE (type
);
2265 index_type
= TYPE_TARGET_TYPE (range_type
);
2266 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2267 index_type
= builtin_type_long
;
2269 *typep
= index_type
;
2271 (LONGEST
) (which
== 0
2272 ? TYPE_LOW_BOUND (range_type
)
2273 : TYPE_HIGH_BOUND (range_type
));
2277 struct type
*index_type
=
2278 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2279 NULL
, TYPE_OBJFILE (arr_type
));
2281 *typep
= TYPE_TARGET_TYPE (index_type
);
2283 (LONGEST
) (which
== 0
2284 ? TYPE_LOW_BOUND (index_type
)
2285 : TYPE_HIGH_BOUND (index_type
));
2289 /* Given that arr is an array value, returns the lower bound of the
2290 nth index (numbering from 1) if which is 0, and the upper bound if
2291 which is 1. This routine will also work for arrays with bounds
2292 supplied by run-time quantities other than discriminants. */
2295 ada_array_bound (struct value
*arr
, int n
, int which
)
2297 struct type
*arr_type
= VALUE_TYPE (arr
);
2299 if (ada_is_packed_array_type (arr_type
))
2300 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2301 else if (ada_is_simple_array_type (arr_type
))
2304 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2305 return value_from_longest (type
, v
);
2308 return desc_one_bound (desc_bounds (arr
), n
, which
);
2311 /* Given that arr is an array value, returns the length of the
2312 nth index. This routine will also work for arrays with bounds
2313 supplied by run-time quantities other than discriminants.
2314 Does not work for arrays indexed by enumeration types with representation
2315 clauses at the moment. */
2318 ada_array_length (struct value
*arr
, int n
)
2320 struct type
*arr_type
= ada_check_typedef (VALUE_TYPE (arr
));
2322 if (ada_is_packed_array_type (arr_type
))
2323 return ada_array_length (decode_packed_array (arr
), n
);
2325 if (ada_is_simple_array_type (arr_type
))
2329 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2330 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2331 return value_from_longest (type
, v
);
2335 value_from_longest (builtin_type_int
,
2336 value_as_long (desc_one_bound (desc_bounds (arr
),
2338 - value_as_long (desc_one_bound (desc_bounds (arr
),
2342 /* An empty array whose type is that of ARR_TYPE (an array type),
2343 with bounds LOW to LOW-1. */
2345 static struct value
*
2346 empty_array (struct type
*arr_type
, int low
)
2348 struct type
*index_type
=
2349 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2351 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2352 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2356 /* Name resolution */
2358 /* The "decoded" name for the user-definable Ada operator corresponding
2362 ada_decoded_op_name (enum exp_opcode op
)
2366 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2368 if (ada_opname_table
[i
].op
== op
)
2369 return ada_opname_table
[i
].decoded
;
2371 error ("Could not find operator name for opcode");
2375 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2376 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2377 undefined namespace) and converts operators that are
2378 user-defined into appropriate function calls. If CONTEXT_TYPE is
2379 non-null, it provides a preferred result type [at the moment, only
2380 type void has any effect---causing procedures to be preferred over
2381 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2382 return type is preferred. May change (expand) *EXP. */
2385 resolve (struct expression
**expp
, int void_context_p
)
2389 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2392 /* Resolve the operator of the subexpression beginning at
2393 position *POS of *EXPP. "Resolving" consists of replacing
2394 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2395 with their resolutions, replacing built-in operators with
2396 function calls to user-defined operators, where appropriate, and,
2397 when DEPROCEDURE_P is non-zero, converting function-valued variables
2398 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2399 are as in ada_resolve, above. */
2401 static struct value
*
2402 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2403 struct type
*context_type
)
2407 struct expression
*exp
; /* Convenience: == *expp. */
2408 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2409 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2410 int nargs
; /* Number of operands. */
2416 /* Pass one: resolve operands, saving their types and updating *pos. */
2420 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2421 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2426 resolve_subexp (expp
, pos
, 0, NULL
);
2428 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2433 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2438 resolve_subexp (expp
, pos
, 0, NULL
);
2441 case OP_ATR_MODULUS
:
2471 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2473 resolve_subexp (expp
, pos
, 1, NULL
);
2475 resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2493 case BINOP_LOGICAL_AND
:
2494 case BINOP_LOGICAL_OR
:
2495 case BINOP_BITWISE_AND
:
2496 case BINOP_BITWISE_IOR
:
2497 case BINOP_BITWISE_XOR
:
2500 case BINOP_NOTEQUAL
:
2507 case BINOP_SUBSCRIPT
:
2515 case UNOP_LOGICAL_NOT
:
2532 case OP_INTERNALVAR
:
2541 case STRUCTOP_STRUCT
:
2542 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2548 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2553 case TERNOP_IN_RANGE
:
2558 case BINOP_IN_BOUNDS
:
2564 error ("Unexpected operator during name resolution");
2567 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2568 for (i
= 0; i
< nargs
; i
+= 1)
2569 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2573 /* Pass two: perform any resolution on principal operator. */
2580 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2582 struct ada_symbol_info
*candidates
;
2586 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2587 (exp
->elts
[pc
+ 2].symbol
),
2588 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2591 if (n_candidates
> 1)
2593 /* Types tend to get re-introduced locally, so if there
2594 are any local symbols that are not types, first filter
2597 for (j
= 0; j
< n_candidates
; j
+= 1)
2598 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2604 case LOC_REGPARM_ADDR
:
2608 case LOC_BASEREG_ARG
:
2610 case LOC_COMPUTED_ARG
:
2616 if (j
< n_candidates
)
2619 while (j
< n_candidates
)
2621 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2623 candidates
[j
] = candidates
[n_candidates
- 1];
2632 if (n_candidates
== 0)
2633 error ("No definition found for %s",
2634 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2635 else if (n_candidates
== 1)
2637 else if (deprocedure_p
2638 && !is_nonfunction (candidates
, n_candidates
))
2640 i
= ada_resolve_function
2641 (candidates
, n_candidates
, NULL
, 0,
2642 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2645 error ("Could not find a match for %s",
2646 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2650 printf_filtered ("Multiple matches for %s\n",
2651 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2652 user_select_syms (candidates
, n_candidates
, 1);
2656 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2657 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2658 if (innermost_block
== NULL
2659 || contained_in (candidates
[i
].block
, innermost_block
))
2660 innermost_block
= candidates
[i
].block
;
2664 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2667 replace_operator_with_call (expp
, pc
, 0, 0,
2668 exp
->elts
[pc
+ 2].symbol
,
2669 exp
->elts
[pc
+ 1].block
);
2676 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2677 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2679 struct ada_symbol_info
*candidates
;
2683 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2684 (exp
->elts
[pc
+ 5].symbol
),
2685 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2687 if (n_candidates
== 1)
2691 i
= ada_resolve_function
2692 (candidates
, n_candidates
,
2694 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2697 error ("Could not find a match for %s",
2698 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2701 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2702 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2703 if (innermost_block
== NULL
2704 || contained_in (candidates
[i
].block
, innermost_block
))
2705 innermost_block
= candidates
[i
].block
;
2716 case BINOP_BITWISE_AND
:
2717 case BINOP_BITWISE_IOR
:
2718 case BINOP_BITWISE_XOR
:
2720 case BINOP_NOTEQUAL
:
2728 case UNOP_LOGICAL_NOT
:
2730 if (possible_user_operator_p (op
, argvec
))
2732 struct ada_symbol_info
*candidates
;
2736 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2737 (struct block
*) NULL
, VAR_DOMAIN
,
2739 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2740 ada_decoded_op_name (op
), NULL
);
2744 replace_operator_with_call (expp
, pc
, nargs
, 1,
2745 candidates
[i
].sym
, candidates
[i
].block
);
2755 return evaluate_subexp_type (exp
, pos
);
2758 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2759 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2760 a non-pointer. A type of 'void' (which is never a valid expression type)
2761 by convention matches anything. */
2762 /* The term "match" here is rather loose. The match is heuristic and
2763 liberal. FIXME: TOO liberal, in fact. */
2766 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2768 ftype
= ada_check_typedef (ftype
);
2769 atype
= ada_check_typedef (atype
);
2771 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2772 ftype
= TYPE_TARGET_TYPE (ftype
);
2773 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2774 atype
= TYPE_TARGET_TYPE (atype
);
2776 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2777 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2780 switch (TYPE_CODE (ftype
))
2785 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2786 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2787 TYPE_TARGET_TYPE (atype
), 0);
2790 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2792 case TYPE_CODE_ENUM
:
2793 case TYPE_CODE_RANGE
:
2794 switch (TYPE_CODE (atype
))
2797 case TYPE_CODE_ENUM
:
2798 case TYPE_CODE_RANGE
:
2804 case TYPE_CODE_ARRAY
:
2805 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2806 || ada_is_array_descriptor_type (atype
));
2808 case TYPE_CODE_STRUCT
:
2809 if (ada_is_array_descriptor_type (ftype
))
2810 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2811 || ada_is_array_descriptor_type (atype
));
2813 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2814 && !ada_is_array_descriptor_type (atype
));
2816 case TYPE_CODE_UNION
:
2818 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2822 /* Return non-zero if the formals of FUNC "sufficiently match" the
2823 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2824 may also be an enumeral, in which case it is treated as a 0-
2825 argument function. */
2828 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2831 struct type
*func_type
= SYMBOL_TYPE (func
);
2833 if (SYMBOL_CLASS (func
) == LOC_CONST
2834 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2835 return (n_actuals
== 0);
2836 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2839 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2842 for (i
= 0; i
< n_actuals
; i
+= 1)
2844 if (actuals
[i
] == NULL
)
2848 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2849 struct type
*atype
= ada_check_typedef (VALUE_TYPE (actuals
[i
]));
2851 if (!ada_type_match (ftype
, atype
, 1))
2858 /* False iff function type FUNC_TYPE definitely does not produce a value
2859 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2860 FUNC_TYPE is not a valid function type with a non-null return type
2861 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2864 return_match (struct type
*func_type
, struct type
*context_type
)
2866 struct type
*return_type
;
2868 if (func_type
== NULL
)
2871 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2872 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2874 return_type
= base_type (func_type
);
2875 if (return_type
== NULL
)
2878 context_type
= base_type (context_type
);
2880 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2881 return context_type
== NULL
|| return_type
== context_type
;
2882 else if (context_type
== NULL
)
2883 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2885 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2889 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
2890 function (if any) that matches the types of the NARGS arguments in
2891 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2892 that returns that type, then eliminate matches that don't. If
2893 CONTEXT_TYPE is void and there is at least one match that does not
2894 return void, eliminate all matches that do.
2896 Asks the user if there is more than one match remaining. Returns -1
2897 if there is no such symbol or none is selected. NAME is used
2898 solely for messages. May re-arrange and modify SYMS in
2899 the process; the index returned is for the modified vector. */
2902 ada_resolve_function (struct ada_symbol_info syms
[],
2903 int nsyms
, struct value
**args
, int nargs
,
2904 const char *name
, struct type
*context_type
)
2907 int m
; /* Number of hits */
2908 struct type
*fallback
;
2909 struct type
*return_type
;
2911 return_type
= context_type
;
2912 if (context_type
== NULL
)
2913 fallback
= builtin_type_void
;
2920 for (k
= 0; k
< nsyms
; k
+= 1)
2922 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
2924 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
2925 && return_match (type
, return_type
))
2931 if (m
> 0 || return_type
== fallback
)
2934 return_type
= fallback
;
2941 printf_filtered ("Multiple matches for %s\n", name
);
2942 user_select_syms (syms
, m
, 1);
2948 /* Returns true (non-zero) iff decoded name N0 should appear before N1
2949 in a listing of choices during disambiguation (see sort_choices, below).
2950 The idea is that overloadings of a subprogram name from the
2951 same package should sort in their source order. We settle for ordering
2952 such symbols by their trailing number (__N or $N). */
2955 encoded_ordered_before (char *N0
, char *N1
)
2959 else if (N0
== NULL
)
2964 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2966 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2968 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2969 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2973 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2976 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2978 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
2979 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
2981 return (strcmp (N0
, N1
) < 0);
2985 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
2989 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
2992 for (i
= 1; i
< nsyms
; i
+= 1)
2994 struct ada_symbol_info sym
= syms
[i
];
2997 for (j
= i
- 1; j
>= 0; j
-= 1)
2999 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3000 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3002 syms
[j
+ 1] = syms
[j
];
3008 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3009 by asking the user (if necessary), returning the number selected,
3010 and setting the first elements of SYMS items. Error if no symbols
3013 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3014 to be re-integrated one of these days. */
3017 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3020 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3022 int first_choice
= (max_results
== 1) ? 1 : 2;
3024 if (max_results
< 1)
3025 error ("Request to select 0 symbols!");
3029 printf_unfiltered ("[0] cancel\n");
3030 if (max_results
> 1)
3031 printf_unfiltered ("[1] all\n");
3033 sort_choices (syms
, nsyms
);
3035 for (i
= 0; i
< nsyms
; i
+= 1)
3037 if (syms
[i
].sym
== NULL
)
3040 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3042 struct symtab_and_line sal
=
3043 find_function_start_sal (syms
[i
].sym
, 1);
3044 printf_unfiltered ("[%d] %s at %s:%d\n", i
+ first_choice
,
3045 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3047 ? "<no source file available>"
3048 : sal
.symtab
->filename
), sal
.line
);
3054 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3055 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3056 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3057 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3059 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3060 printf_unfiltered ("[%d] %s at %s:%d\n",
3062 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3063 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3064 else if (is_enumeral
3065 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3067 printf_unfiltered ("[%d] ", i
+ first_choice
);
3068 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3070 printf_unfiltered ("'(%s) (enumeral)\n",
3071 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3073 else if (symtab
!= NULL
)
3074 printf_unfiltered (is_enumeral
3075 ? "[%d] %s in %s (enumeral)\n"
3076 : "[%d] %s at %s:?\n",
3078 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3081 printf_unfiltered (is_enumeral
3082 ? "[%d] %s (enumeral)\n"
3085 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3089 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3092 for (i
= 0; i
< n_chosen
; i
+= 1)
3093 syms
[i
] = syms
[chosen
[i
]];
3098 /* Read and validate a set of numeric choices from the user in the
3099 range 0 .. N_CHOICES-1. Place the results in increasing
3100 order in CHOICES[0 .. N-1], and return N.
3102 The user types choices as a sequence of numbers on one line
3103 separated by blanks, encoding them as follows:
3105 + A choice of 0 means to cancel the selection, throwing an error.
3106 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3107 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3109 The user is not allowed to choose more than MAX_RESULTS values.
3111 ANNOTATION_SUFFIX, if present, is used to annotate the input
3112 prompts (for use with the -f switch). */
3115 get_selections (int *choices
, int n_choices
, int max_results
,
3116 int is_all_choice
, char *annotation_suffix
)
3121 int first_choice
= is_all_choice
? 2 : 1;
3123 prompt
= getenv ("PS2");
3127 printf_unfiltered ("%s ", prompt
);
3128 gdb_flush (gdb_stdout
);
3130 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3133 error_no_arg ("one or more choice numbers");
3137 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3138 order, as given in args. Choices are validated. */
3144 while (isspace (*args
))
3146 if (*args
== '\0' && n_chosen
== 0)
3147 error_no_arg ("one or more choice numbers");
3148 else if (*args
== '\0')
3151 choice
= strtol (args
, &args2
, 10);
3152 if (args
== args2
|| choice
< 0
3153 || choice
> n_choices
+ first_choice
- 1)
3154 error ("Argument must be choice number");
3158 error ("cancelled");
3160 if (choice
< first_choice
)
3162 n_chosen
= n_choices
;
3163 for (j
= 0; j
< n_choices
; j
+= 1)
3167 choice
-= first_choice
;
3169 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3173 if (j
< 0 || choice
!= choices
[j
])
3176 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3177 choices
[k
+ 1] = choices
[k
];
3178 choices
[j
+ 1] = choice
;
3183 if (n_chosen
> max_results
)
3184 error ("Select no more than %d of the above", max_results
);
3189 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3190 on the function identified by SYM and BLOCK, and taking NARGS
3191 arguments. Update *EXPP as needed to hold more space. */
3194 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3195 int oplen
, struct symbol
*sym
,
3196 struct block
*block
)
3198 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3199 symbol, -oplen for operator being replaced). */
3200 struct expression
*newexp
= (struct expression
*)
3201 xmalloc (sizeof (struct expression
)
3202 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3203 struct expression
*exp
= *expp
;
3205 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3206 newexp
->language_defn
= exp
->language_defn
;
3207 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3208 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3209 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3211 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3212 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3214 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3215 newexp
->elts
[pc
+ 4].block
= block
;
3216 newexp
->elts
[pc
+ 5].symbol
= sym
;
3222 /* Type-class predicates */
3224 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3228 numeric_type_p (struct type
*type
)
3234 switch (TYPE_CODE (type
))
3239 case TYPE_CODE_RANGE
:
3240 return (type
== TYPE_TARGET_TYPE (type
)
3241 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3248 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3251 integer_type_p (struct type
*type
)
3257 switch (TYPE_CODE (type
))
3261 case TYPE_CODE_RANGE
:
3262 return (type
== TYPE_TARGET_TYPE (type
)
3263 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3270 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3273 scalar_type_p (struct type
*type
)
3279 switch (TYPE_CODE (type
))
3282 case TYPE_CODE_RANGE
:
3283 case TYPE_CODE_ENUM
:
3292 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3295 discrete_type_p (struct type
*type
)
3301 switch (TYPE_CODE (type
))
3304 case TYPE_CODE_RANGE
:
3305 case TYPE_CODE_ENUM
:
3313 /* Returns non-zero if OP with operands in the vector ARGS could be
3314 a user-defined function. Errs on the side of pre-defined operators
3315 (i.e., result 0). */
3318 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3320 struct type
*type0
=
3321 (args
[0] == NULL
) ? NULL
: ada_check_typedef (VALUE_TYPE (args
[0]));
3322 struct type
*type1
=
3323 (args
[1] == NULL
) ? NULL
: ada_check_typedef (VALUE_TYPE (args
[1]));
3337 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3341 case BINOP_BITWISE_AND
:
3342 case BINOP_BITWISE_IOR
:
3343 case BINOP_BITWISE_XOR
:
3344 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3347 case BINOP_NOTEQUAL
:
3352 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3356 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3357 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3358 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3359 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3360 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3361 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
))
3362 != TYPE_CODE_ARRAY
))));
3365 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3369 case UNOP_LOGICAL_NOT
:
3371 return (!numeric_type_p (type0
));
3378 /* NOTE: In the following, we assume that a renaming type's name may
3379 have an ___XD suffix. It would be nice if this went away at some
3382 /* If TYPE encodes a renaming, returns the renaming suffix, which
3383 is XR for an object renaming, XRP for a procedure renaming, XRE for
3384 an exception renaming, and XRS for a subprogram renaming. Returns
3385 NULL if NAME encodes none of these. */
3388 ada_renaming_type (struct type
*type
)
3390 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3392 const char *name
= type_name_no_tag (type
);
3393 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3395 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3404 /* Return non-zero iff SYM encodes an object renaming. */
3407 ada_is_object_renaming (struct symbol
*sym
)
3409 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3410 return renaming_type
!= NULL
3411 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3414 /* Assuming that SYM encodes a non-object renaming, returns the original
3415 name of the renamed entity. The name is good until the end of
3419 ada_simple_renamed_entity (struct symbol
*sym
)
3422 const char *raw_name
;
3426 type
= SYMBOL_TYPE (sym
);
3427 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3428 error ("Improperly encoded renaming.");
3430 raw_name
= TYPE_FIELD_NAME (type
, 0);
3431 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3433 error ("Improperly encoded renaming.");
3435 result
= xmalloc (len
+ 1);
3436 strncpy (result
, raw_name
, len
);
3437 result
[len
] = '\000';
3442 /* Evaluation: Function Calls */
3444 /* Return an lvalue containing the value VAL. This is the identity on
3445 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3446 on the stack, using and updating *SP as the stack pointer, and
3447 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3449 static struct value
*
3450 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3452 if (! VALUE_LVAL (val
))
3454 int len
= TYPE_LENGTH (ada_check_typedef (VALUE_TYPE (val
)));
3456 /* The following is taken from the structure-return code in
3457 call_function_by_hand. FIXME: Therefore, some refactoring seems
3459 if (INNER_THAN (1, 2))
3461 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3462 reserving sufficient space. */
3464 if (gdbarch_frame_align_p (current_gdbarch
))
3465 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3466 VALUE_ADDRESS (val
) = *sp
;
3470 /* Stack grows upward. Align the frame, allocate space, and
3471 then again, re-align the frame. */
3472 if (gdbarch_frame_align_p (current_gdbarch
))
3473 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3474 VALUE_ADDRESS (val
) = *sp
;
3476 if (gdbarch_frame_align_p (current_gdbarch
))
3477 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3480 write_memory (VALUE_ADDRESS (val
), VALUE_CONTENTS_RAW (val
), len
);
3486 /* Return the value ACTUAL, converted to be an appropriate value for a
3487 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3488 allocating any necessary descriptors (fat pointers), or copies of
3489 values not residing in memory, updating it as needed. */
3491 static struct value
*
3492 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3495 struct type
*actual_type
= ada_check_typedef (VALUE_TYPE (actual
));
3496 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3497 struct type
*formal_target
=
3498 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3499 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3500 struct type
*actual_target
=
3501 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3502 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3504 if (ada_is_array_descriptor_type (formal_target
)
3505 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3506 return make_array_descriptor (formal_type
, actual
, sp
);
3507 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3509 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3510 && ada_is_array_descriptor_type (actual_target
))
3511 return desc_data (actual
);
3512 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3514 if (VALUE_LVAL (actual
) != lval_memory
)
3517 actual_type
= ada_check_typedef (VALUE_TYPE (actual
));
3518 val
= allocate_value (actual_type
);
3519 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3520 (char *) VALUE_CONTENTS (actual
),
3521 TYPE_LENGTH (actual_type
));
3522 actual
= ensure_lval (val
, sp
);
3524 return value_addr (actual
);
3527 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3528 return ada_value_ind (actual
);
3534 /* Push a descriptor of type TYPE for array value ARR on the stack at
3535 *SP, updating *SP to reflect the new descriptor. Return either
3536 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3537 to-descriptor type rather than a descriptor type), a struct value *
3538 representing a pointer to this descriptor. */
3540 static struct value
*
3541 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3543 struct type
*bounds_type
= desc_bounds_type (type
);
3544 struct type
*desc_type
= desc_base_type (type
);
3545 struct value
*descriptor
= allocate_value (desc_type
);
3546 struct value
*bounds
= allocate_value (bounds_type
);
3549 for (i
= ada_array_arity (ada_check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3551 modify_general_field (VALUE_CONTENTS (bounds
),
3552 value_as_long (ada_array_bound (arr
, i
, 0)),
3553 desc_bound_bitpos (bounds_type
, i
, 0),
3554 desc_bound_bitsize (bounds_type
, i
, 0));
3555 modify_general_field (VALUE_CONTENTS (bounds
),
3556 value_as_long (ada_array_bound (arr
, i
, 1)),
3557 desc_bound_bitpos (bounds_type
, i
, 1),
3558 desc_bound_bitsize (bounds_type
, i
, 1));
3561 bounds
= ensure_lval (bounds
, sp
);
3563 modify_general_field (VALUE_CONTENTS (descriptor
),
3564 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3565 fat_pntr_data_bitpos (desc_type
),
3566 fat_pntr_data_bitsize (desc_type
));
3568 modify_general_field (VALUE_CONTENTS (descriptor
),
3569 VALUE_ADDRESS (bounds
),
3570 fat_pntr_bounds_bitpos (desc_type
),
3571 fat_pntr_bounds_bitsize (desc_type
));
3573 descriptor
= ensure_lval (descriptor
, sp
);
3575 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3576 return value_addr (descriptor
);
3582 /* Assuming a dummy frame has been established on the target, perform any
3583 conversions needed for calling function FUNC on the NARGS actual
3584 parameters in ARGS, other than standard C conversions. Does
3585 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3586 does not match the number of arguments expected. Use *SP as a
3587 stack pointer for additional data that must be pushed, updating its
3591 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3596 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3597 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3600 for (i
= 0; i
< nargs
; i
+= 1)
3602 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3605 /* Dummy definitions for an experimental caching module that is not
3606 * used in the public sources. */
3609 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3610 struct symbol
**sym
, struct block
**block
,
3611 struct symtab
**symtab
)
3617 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3618 struct block
*block
, struct symtab
*symtab
)
3624 /* Return the result of a standard (literal, C-like) lookup of NAME in
3625 given DOMAIN, visible from lexical block BLOCK. */
3627 static struct symbol
*
3628 standard_lookup (const char *name
, const struct block
*block
,
3632 struct symtab
*symtab
;
3634 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3637 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3638 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3643 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3644 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3645 since they contend in overloading in the same way. */
3647 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3651 for (i
= 0; i
< n
; i
+= 1)
3652 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3653 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3654 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3660 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3661 struct types. Otherwise, they may not. */
3664 equiv_types (struct type
*type0
, struct type
*type1
)
3668 if (type0
== NULL
|| type1
== NULL
3669 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3671 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3672 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3673 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3674 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3680 /* True iff SYM0 represents the same entity as SYM1, or one that is
3681 no more defined than that of SYM1. */
3684 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3688 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3689 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3692 switch (SYMBOL_CLASS (sym0
))
3698 struct type
*type0
= SYMBOL_TYPE (sym0
);
3699 struct type
*type1
= SYMBOL_TYPE (sym1
);
3700 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3701 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3702 int len0
= strlen (name0
);
3704 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3705 && (equiv_types (type0
, type1
)
3706 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3707 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3710 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3711 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3717 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3718 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3721 add_defn_to_vec (struct obstack
*obstackp
,
3723 struct block
*block
, struct symtab
*symtab
)
3727 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3729 if (SYMBOL_TYPE (sym
) != NULL
)
3730 SYMBOL_TYPE (sym
) = ada_check_typedef (SYMBOL_TYPE (sym
));
3731 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3733 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3735 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3737 prevDefns
[i
].sym
= sym
;
3738 prevDefns
[i
].block
= block
;
3739 prevDefns
[i
].symtab
= symtab
;
3745 struct ada_symbol_info info
;
3749 info
.symtab
= symtab
;
3750 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3754 /* Number of ada_symbol_info structures currently collected in
3755 current vector in *OBSTACKP. */
3758 num_defns_collected (struct obstack
*obstackp
)
3760 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3763 /* Vector of ada_symbol_info structures currently collected in current
3764 vector in *OBSTACKP. If FINISH, close off the vector and return
3765 its final address. */
3767 static struct ada_symbol_info
*
3768 defns_collected (struct obstack
*obstackp
, int finish
)
3771 return obstack_finish (obstackp
);
3773 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3776 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3777 Check the global symbols if GLOBAL, the static symbols if not.
3778 Do wild-card match if WILD. */
3780 static struct partial_symbol
*
3781 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3782 int global
, domain_enum
namespace, int wild
)
3784 struct partial_symbol
**start
;
3785 int name_len
= strlen (name
);
3786 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3795 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3796 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3800 for (i
= 0; i
< length
; i
+= 1)
3802 struct partial_symbol
*psym
= start
[i
];
3804 if (SYMBOL_DOMAIN (psym
) == namespace
3805 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3819 int M
= (U
+ i
) >> 1;
3820 struct partial_symbol
*psym
= start
[M
];
3821 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3823 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3825 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
3836 struct partial_symbol
*psym
= start
[i
];
3838 if (SYMBOL_DOMAIN (psym
) == namespace)
3840 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
3848 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3862 int M
= (U
+ i
) >> 1;
3863 struct partial_symbol
*psym
= start
[M
];
3864 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
3866 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
3868 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
3879 struct partial_symbol
*psym
= start
[i
];
3881 if (SYMBOL_DOMAIN (psym
) == namespace)
3885 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
3888 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
3890 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
3900 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3910 /* Find a symbol table containing symbol SYM or NULL if none. */
3912 static struct symtab
*
3913 symtab_for_sym (struct symbol
*sym
)
3916 struct objfile
*objfile
;
3918 struct symbol
*tmp_sym
;
3919 struct dict_iterator iter
;
3922 ALL_SYMTABS (objfile
, s
)
3924 switch (SYMBOL_CLASS (sym
))
3932 case LOC_CONST_BYTES
:
3933 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3934 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3936 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3937 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3943 switch (SYMBOL_CLASS (sym
))
3949 case LOC_REGPARM_ADDR
:
3954 case LOC_BASEREG_ARG
:
3956 case LOC_COMPUTED_ARG
:
3957 for (j
= FIRST_LOCAL_BLOCK
;
3958 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3960 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3961 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3972 /* Return a minimal symbol matching NAME according to Ada decoding
3973 rules. Returns NULL if there is no such minimal symbol. Names
3974 prefixed with "standard__" are handled specially: "standard__" is
3975 first stripped off, and only static and global symbols are searched. */
3977 struct minimal_symbol
*
3978 ada_lookup_simple_minsym (const char *name
)
3980 struct objfile
*objfile
;
3981 struct minimal_symbol
*msymbol
;
3984 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
3986 name
+= sizeof ("standard__") - 1;
3990 wild_match
= (strstr (name
, "__") == NULL
);
3992 ALL_MSYMBOLS (objfile
, msymbol
)
3994 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
3995 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4002 /* For all subprograms that statically enclose the subprogram of the
4003 selected frame, add symbols matching identifier NAME in DOMAIN
4004 and their blocks to the list of data in OBSTACKP, as for
4005 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4009 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4010 const char *name
, domain_enum
namespace,
4015 /* FIXME: The next two routines belong in symtab.c */
4018 restore_language (void *lang
)
4020 set_language ((enum language
) lang
);
4023 /* As for lookup_symbol, but performed as if the current language
4027 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4028 domain_enum domain
, enum language lang
,
4029 int *is_a_field_of_this
, struct symtab
**symtab
)
4031 struct cleanup
*old_chain
4032 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4033 struct symbol
*result
;
4034 set_language (lang
);
4035 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4036 do_cleanups (old_chain
);
4040 /* True if TYPE is definitely an artificial type supplied to a symbol
4041 for which no debugging information was given in the symbol file. */
4044 is_nondebugging_type (struct type
*type
)
4046 char *name
= ada_type_name (type
);
4047 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4050 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4051 duplicate other symbols in the list (The only case I know of where
4052 this happens is when object files containing stabs-in-ecoff are
4053 linked with files containing ordinary ecoff debugging symbols (or no
4054 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4055 Returns the number of items in the modified list. */
4058 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4065 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4066 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4067 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4069 for (j
= 0; j
< nsyms
; j
+= 1)
4072 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4073 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4074 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4075 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4076 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4077 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4080 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4081 syms
[k
- 1] = syms
[k
];
4094 /* Given a type that corresponds to a renaming entity, use the type name
4095 to extract the scope (package name or function name, fully qualified,
4096 and following the GNAT encoding convention) where this renaming has been
4097 defined. The string returned needs to be deallocated after use. */
4100 xget_renaming_scope (struct type
*renaming_type
)
4102 /* The renaming types adhere to the following convention:
4103 <scope>__<rename>___<XR extension>.
4104 So, to extract the scope, we search for the "___XR" extension,
4105 and then backtrack until we find the first "__". */
4107 const char *name
= type_name_no_tag (renaming_type
);
4108 char *suffix
= strstr (name
, "___XR");
4113 /* Now, backtrack a bit until we find the first "__". Start looking
4114 at suffix - 3, as the <rename> part is at least one character long. */
4116 for (last
= suffix
- 3; last
> name
; last
--)
4117 if (last
[0] == '_' && last
[1] == '_')
4120 /* Make a copy of scope and return it. */
4122 scope_len
= last
- name
;
4123 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4125 strncpy (scope
, name
, scope_len
);
4126 scope
[scope_len
] = '\0';
4131 /* Return nonzero if NAME corresponds to a package name. */
4134 is_package_name (const char *name
)
4136 /* Here, We take advantage of the fact that no symbols are generated
4137 for packages, while symbols are generated for each function.
4138 So the condition for NAME represent a package becomes equivalent
4139 to NAME not existing in our list of symbols. There is only one
4140 small complication with library-level functions (see below). */
4144 /* If it is a function that has not been defined at library level,
4145 then we should be able to look it up in the symbols. */
4146 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4149 /* Library-level function names start with "_ada_". See if function
4150 "_ada_" followed by NAME can be found. */
4152 /* Do a quick check that NAME does not contain "__", since library-level
4153 functions names can not contain "__" in them. */
4154 if (strstr (name
, "__") != NULL
)
4157 fun_name
= xstrprintf ("_ada_%s", name
);
4159 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4162 /* Return nonzero if SYM corresponds to a renaming entity that is
4163 visible from FUNCTION_NAME. */
4166 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4168 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4170 make_cleanup (xfree
, scope
);
4172 /* If the rename has been defined in a package, then it is visible. */
4173 if (is_package_name (scope
))
4176 /* Check that the rename is in the current function scope by checking
4177 that its name starts with SCOPE. */
4179 /* If the function name starts with "_ada_", it means that it is
4180 a library-level function. Strip this prefix before doing the
4181 comparison, as the encoding for the renaming does not contain
4183 if (strncmp (function_name
, "_ada_", 5) == 0)
4186 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4189 /* Iterates over the SYMS list and remove any entry that corresponds to
4190 a renaming entity that is not visible from the function associated
4194 GNAT emits a type following a specified encoding for each renaming
4195 entity. Unfortunately, STABS currently does not support the definition
4196 of types that are local to a given lexical block, so all renamings types
4197 are emitted at library level. As a consequence, if an application
4198 contains two renaming entities using the same name, and a user tries to
4199 print the value of one of these entities, the result of the ada symbol
4200 lookup will also contain the wrong renaming type.
4202 This function partially covers for this limitation by attempting to
4203 remove from the SYMS list renaming symbols that should be visible
4204 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4205 method with the current information available. The implementation
4206 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4208 - When the user tries to print a rename in a function while there
4209 is another rename entity defined in a package: Normally, the
4210 rename in the function has precedence over the rename in the
4211 package, so the latter should be removed from the list. This is
4212 currently not the case.
4214 - This function will incorrectly remove valid renames if
4215 the CURRENT_BLOCK corresponds to a function which symbol name
4216 has been changed by an "Export" pragma. As a consequence,
4217 the user will be unable to print such rename entities. */
4220 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4221 int nsyms
, struct block
*current_block
)
4223 struct symbol
*current_function
;
4224 char *current_function_name
;
4227 /* Extract the function name associated to CURRENT_BLOCK.
4228 Abort if unable to do so. */
4230 if (current_block
== NULL
)
4233 current_function
= block_function (current_block
);
4234 if (current_function
== NULL
)
4237 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4238 if (current_function_name
== NULL
)
4241 /* Check each of the symbols, and remove it from the list if it is
4242 a type corresponding to a renaming that is out of the scope of
4243 the current block. */
4248 if (ada_is_object_renaming (syms
[i
].sym
)
4249 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4252 for (j
= i
+ 1; j
< nsyms
; j
++)
4253 syms
[j
- 1] = syms
[j
];
4263 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4264 scope and in global scopes, returning the number of matches. Sets
4265 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4266 indicating the symbols found and the blocks and symbol tables (if
4267 any) in which they were found. This vector are transient---good only to
4268 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4269 symbol match within the nest of blocks whose innermost member is BLOCK0,
4270 is the one match returned (no other matches in that or
4271 enclosing blocks is returned). If there are any matches in or
4272 surrounding BLOCK0, then these alone are returned. Otherwise, the
4273 search extends to global and file-scope (static) symbol tables.
4274 Names prefixed with "standard__" are handled specially: "standard__"
4275 is first stripped off, and only static and global symbols are searched. */
4278 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4279 domain_enum
namespace,
4280 struct ada_symbol_info
**results
)
4284 struct partial_symtab
*ps
;
4285 struct blockvector
*bv
;
4286 struct objfile
*objfile
;
4287 struct block
*block
;
4289 struct minimal_symbol
*msymbol
;
4295 obstack_free (&symbol_list_obstack
, NULL
);
4296 obstack_init (&symbol_list_obstack
);
4300 /* Search specified block and its superiors. */
4302 wild_match
= (strstr (name0
, "__") == NULL
);
4304 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4305 needed, but adding const will
4306 have a cascade effect. */
4307 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4311 name
= name0
+ sizeof ("standard__") - 1;
4315 while (block
!= NULL
)
4318 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4319 namespace, NULL
, NULL
, wild_match
);
4321 /* If we found a non-function match, assume that's the one. */
4322 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4323 num_defns_collected (&symbol_list_obstack
)))
4326 block
= BLOCK_SUPERBLOCK (block
);
4329 /* If no luck so far, try to find NAME as a local symbol in some lexically
4330 enclosing subprogram. */
4331 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4332 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4333 name
, namespace, wild_match
);
4335 /* If we found ANY matches among non-global symbols, we're done. */
4337 if (num_defns_collected (&symbol_list_obstack
) > 0)
4341 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4344 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4348 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4349 tables, and psymtab's. */
4351 ALL_SYMTABS (objfile
, s
)
4356 bv
= BLOCKVECTOR (s
);
4357 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4358 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4359 objfile
, s
, wild_match
);
4362 if (namespace == VAR_DOMAIN
)
4364 ALL_MSYMBOLS (objfile
, msymbol
)
4366 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4368 switch (MSYMBOL_TYPE (msymbol
))
4370 case mst_solib_trampoline
:
4373 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4376 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4378 bv
= BLOCKVECTOR (s
);
4379 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4380 ada_add_block_symbols (&symbol_list_obstack
, block
,
4381 SYMBOL_LINKAGE_NAME (msymbol
),
4382 namespace, objfile
, s
, wild_match
);
4384 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4386 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4387 ada_add_block_symbols (&symbol_list_obstack
, block
,
4388 SYMBOL_LINKAGE_NAME (msymbol
),
4389 namespace, objfile
, s
,
4398 ALL_PSYMTABS (objfile
, ps
)
4402 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4404 s
= PSYMTAB_TO_SYMTAB (ps
);
4407 bv
= BLOCKVECTOR (s
);
4408 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4409 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4410 namespace, objfile
, s
, wild_match
);
4414 /* Now add symbols from all per-file blocks if we've gotten no hits
4415 (Not strictly correct, but perhaps better than an error).
4416 Do the symtabs first, then check the psymtabs. */
4418 if (num_defns_collected (&symbol_list_obstack
) == 0)
4421 ALL_SYMTABS (objfile
, s
)
4426 bv
= BLOCKVECTOR (s
);
4427 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4428 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4429 objfile
, s
, wild_match
);
4432 ALL_PSYMTABS (objfile
, ps
)
4436 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4438 s
= PSYMTAB_TO_SYMTAB (ps
);
4439 bv
= BLOCKVECTOR (s
);
4442 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4443 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4444 namespace, objfile
, s
, wild_match
);
4450 ndefns
= num_defns_collected (&symbol_list_obstack
);
4451 *results
= defns_collected (&symbol_list_obstack
, 1);
4453 ndefns
= remove_extra_symbols (*results
, ndefns
);
4456 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4458 if (ndefns
== 1 && cacheIfUnique
)
4459 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4460 (*results
)[0].symtab
);
4462 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4463 (struct block
*) block0
);
4468 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4469 scope and in global scopes, or NULL if none. NAME is folded and
4470 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4471 but is disambiguated by user query if needed. *IS_A_FIELD_OF_THIS is
4472 set to 0 and *SYMTAB is set to the symbol table in which the symbol
4473 was found (in both cases, these assignments occur only if the
4474 pointers are non-null). */
4476 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4477 domain_enum
namespace, int *is_a_field_of_this
,
4478 struct symtab
**symtab
)
4480 struct ada_symbol_info
*candidates
;
4483 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4484 block0
, namespace, &candidates
);
4486 if (n_candidates
== 0)
4489 if (is_a_field_of_this
!= NULL
)
4490 *is_a_field_of_this
= 0;
4494 *symtab
= candidates
[0].symtab
;
4495 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4497 struct objfile
*objfile
;
4500 struct blockvector
*bv
;
4502 /* Search the list of symtabs for one which contains the
4503 address of the start of this block. */
4504 ALL_SYMTABS (objfile
, s
)
4506 bv
= BLOCKVECTOR (s
);
4507 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4508 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4509 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4512 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4514 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4518 return candidates
[0].sym
;
4521 static struct symbol
*
4522 ada_lookup_symbol_nonlocal (const char *name
,
4523 const char *linkage_name
,
4524 const struct block
*block
,
4525 const domain_enum domain
, struct symtab
**symtab
)
4527 if (linkage_name
== NULL
)
4528 linkage_name
= name
;
4529 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4534 /* True iff STR is a possible encoded suffix of a normal Ada name
4535 that is to be ignored for matching purposes. Suffixes of parallel
4536 names (e.g., XVE) are not included here. Currently, the possible suffixes
4537 are given by either of the regular expression:
4539 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4541 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4542 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4546 is_name_suffix (const char *str
)
4549 const char *matching
;
4550 const int len
= strlen (str
);
4552 /* (__[0-9]+)?\.[0-9]+ */
4554 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4557 while (isdigit (matching
[0]))
4559 if (matching
[0] == '\0')
4563 if (matching
[0] == '.')
4566 while (isdigit (matching
[0]))
4568 if (matching
[0] == '\0')
4573 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4576 while (isdigit (matching
[0]))
4578 if (matching
[0] == '\0')
4582 /* ??? We should not modify STR directly, as we are doing below. This
4583 is fine in this case, but may become problematic later if we find
4584 that this alternative did not work, and want to try matching
4585 another one from the begining of STR. Since we modified it, we
4586 won't be able to find the begining of the string anymore! */
4590 while (str
[0] != '_' && str
[0] != '\0')
4592 if (str
[0] != 'n' && str
[0] != 'b')
4597 if (str
[0] == '\000')
4601 if (str
[1] != '_' || str
[2] == '\000')
4605 if (strcmp (str
+ 3, "JM") == 0)
4607 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4608 the LJM suffix in favor of the JM one. But we will
4609 still accept LJM as a valid suffix for a reasonable
4610 amount of time, just to allow ourselves to debug programs
4611 compiled using an older version of GNAT. */
4612 if (strcmp (str
+ 3, "LJM") == 0)
4616 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4617 || str
[4] == 'U' || str
[4] == 'P')
4619 if (str
[4] == 'R' && str
[5] != 'T')
4623 if (!isdigit (str
[2]))
4625 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4626 if (!isdigit (str
[k
]) && str
[k
] != '_')
4630 if (str
[0] == '$' && isdigit (str
[1]))
4632 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4633 if (!isdigit (str
[k
]) && str
[k
] != '_')
4640 /* Return nonzero if the given string starts with a dot ('.')
4641 followed by zero or more digits.
4643 Note: brobecker/2003-11-10: A forward declaration has not been
4644 added at the begining of this file yet, because this function
4645 is only used to work around a problem found during wild matching
4646 when trying to match minimal symbol names against symbol names
4647 obtained from dwarf-2 data. This function is therefore currently
4648 only used in wild_match() and is likely to be deleted when the
4649 problem in dwarf-2 is fixed. */
4652 is_dot_digits_suffix (const char *str
)
4658 while (isdigit (str
[0]))
4660 return (str
[0] == '\0');
4663 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4664 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4665 informational suffixes of NAME (i.e., for which is_name_suffix is
4669 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4675 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4676 stored in the symbol table for nested function names is sometimes
4677 different from the name of the associated entity stored in
4678 the dwarf-2 data: This is the case for nested subprograms, where
4679 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4680 while the symbol name from the dwarf-2 data does not.
4682 Although the DWARF-2 standard documents that entity names stored
4683 in the dwarf-2 data should be identical to the name as seen in
4684 the source code, GNAT takes a different approach as we already use
4685 a special encoding mechanism to convey the information so that
4686 a C debugger can still use the information generated to debug
4687 Ada programs. A corollary is that the symbol names in the dwarf-2
4688 data should match the names found in the symbol table. I therefore
4689 consider this issue as a compiler defect.
4691 Until the compiler is properly fixed, we work-around the problem
4692 by ignoring such suffixes during the match. We do so by making
4693 a copy of PATN0 and NAME0, and then by stripping such a suffix
4694 if present. We then perform the match on the resulting strings. */
4697 name_len
= strlen (name0
);
4699 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4700 strcpy (name
, name0
);
4701 dot
= strrchr (name
, '.');
4702 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4705 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4706 strncpy (patn
, patn0
, patn_len
);
4707 patn
[patn_len
] = '\0';
4708 dot
= strrchr (patn
, '.');
4709 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4712 patn_len
= dot
- patn
;
4716 /* Now perform the wild match. */
4718 name_len
= strlen (name
);
4719 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4720 && strncmp (patn
, name
+ 5, patn_len
) == 0
4721 && is_name_suffix (name
+ patn_len
+ 5))
4724 while (name_len
>= patn_len
)
4726 if (strncmp (patn
, name
, patn_len
) == 0
4727 && is_name_suffix (name
+ patn_len
))
4735 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4740 if (!islower (name
[2]))
4747 if (!islower (name
[1]))
4758 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4759 vector *defn_symbols, updating the list of symbols in OBSTACKP
4760 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4761 OBJFILE is the section containing BLOCK.
4762 SYMTAB is recorded with each symbol added. */
4765 ada_add_block_symbols (struct obstack
*obstackp
,
4766 struct block
*block
, const char *name
,
4767 domain_enum domain
, struct objfile
*objfile
,
4768 struct symtab
*symtab
, int wild
)
4770 struct dict_iterator iter
;
4771 int name_len
= strlen (name
);
4772 /* A matching argument symbol, if any. */
4773 struct symbol
*arg_sym
;
4774 /* Set true when we find a matching non-argument symbol. */
4783 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4785 if (SYMBOL_DOMAIN (sym
) == domain
4786 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
4788 switch (SYMBOL_CLASS (sym
))
4794 case LOC_REGPARM_ADDR
:
4795 case LOC_BASEREG_ARG
:
4796 case LOC_COMPUTED_ARG
:
4799 case LOC_UNRESOLVED
:
4803 add_defn_to_vec (obstackp
,
4804 fixup_symbol_section (sym
, objfile
),
4813 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4815 if (SYMBOL_DOMAIN (sym
) == domain
)
4817 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
4819 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
4821 switch (SYMBOL_CLASS (sym
))
4827 case LOC_REGPARM_ADDR
:
4828 case LOC_BASEREG_ARG
:
4829 case LOC_COMPUTED_ARG
:
4832 case LOC_UNRESOLVED
:
4836 add_defn_to_vec (obstackp
,
4837 fixup_symbol_section (sym
, objfile
),
4846 if (!found_sym
&& arg_sym
!= NULL
)
4848 add_defn_to_vec (obstackp
,
4849 fixup_symbol_section (arg_sym
, objfile
),
4858 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4860 if (SYMBOL_DOMAIN (sym
) == domain
)
4864 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
4867 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
4869 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
4874 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
4876 switch (SYMBOL_CLASS (sym
))
4882 case LOC_REGPARM_ADDR
:
4883 case LOC_BASEREG_ARG
:
4884 case LOC_COMPUTED_ARG
:
4887 case LOC_UNRESOLVED
:
4891 add_defn_to_vec (obstackp
,
4892 fixup_symbol_section (sym
, objfile
),
4900 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4901 They aren't parameters, right? */
4902 if (!found_sym
&& arg_sym
!= NULL
)
4904 add_defn_to_vec (obstackp
,
4905 fixup_symbol_section (arg_sym
, objfile
),
4913 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
4914 to be invisible to users. */
4917 ada_is_ignored_field (struct type
*type
, int field_num
)
4919 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
4923 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
4924 return (name
== NULL
4925 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
4929 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
4930 pointer or reference type whose ultimate target has a tag field. */
4933 ada_is_tagged_type (struct type
*type
, int refok
)
4935 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
4938 /* True iff TYPE represents the type of X'Tag */
4941 ada_is_tag_type (struct type
*type
)
4943 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
4947 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
4948 return (name
!= NULL
4949 && strcmp (name
, "ada__tags__dispatch_table") == 0);
4953 /* The type of the tag on VAL. */
4956 ada_tag_type (struct value
*val
)
4958 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 1, 0, NULL
);
4961 /* The value of the tag on VAL. */
4964 ada_value_tag (struct value
*val
)
4966 return ada_value_struct_elt (val
, "_tag", "record");
4969 /* The value of the tag on the object of type TYPE whose contents are
4970 saved at VALADDR, if it is non-null, or is at memory address
4973 static struct value
*
4974 value_tag_from_contents_and_address (struct type
*type
, char *valaddr
,
4977 int tag_byte_offset
, dummy1
, dummy2
;
4978 struct type
*tag_type
;
4979 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
4982 char *valaddr1
= (valaddr
== NULL
) ? NULL
: valaddr
+ tag_byte_offset
;
4983 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
4985 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
4990 static struct type
*
4991 type_from_tag (struct value
*tag
)
4993 const char *type_name
= ada_tag_name (tag
);
4994 if (type_name
!= NULL
)
4995 return ada_find_any_type (ada_encode (type_name
));
5005 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5006 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5007 The value stored in ARGS->name is valid until the next call to
5011 ada_tag_name_1 (void *args0
)
5013 struct tag_args
*args
= (struct tag_args
*) args0
;
5014 static char name
[1024];
5018 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
5021 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
5024 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5025 for (p
= name
; *p
!= '\0'; p
+= 1)
5032 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5036 ada_tag_name (struct value
*tag
)
5038 struct tag_args args
;
5039 if (!ada_is_tag_type (VALUE_TYPE (tag
)))
5043 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5047 /* The parent type of TYPE, or NULL if none. */
5050 ada_parent_type (struct type
*type
)
5054 type
= ada_check_typedef (type
);
5056 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5059 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5060 if (ada_is_parent_field (type
, i
))
5061 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5066 /* True iff field number FIELD_NUM of structure type TYPE contains the
5067 parent-type (inherited) fields of a derived type. Assumes TYPE is
5068 a structure type with at least FIELD_NUM+1 fields. */
5071 ada_is_parent_field (struct type
*type
, int field_num
)
5073 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5074 return (name
!= NULL
5075 && (strncmp (name
, "PARENT", 6) == 0
5076 || strncmp (name
, "_parent", 7) == 0));
5079 /* True iff field number FIELD_NUM of structure type TYPE is a
5080 transparent wrapper field (which should be silently traversed when doing
5081 field selection and flattened when printing). Assumes TYPE is a
5082 structure type with at least FIELD_NUM+1 fields. Such fields are always
5086 ada_is_wrapper_field (struct type
*type
, int field_num
)
5088 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5089 return (name
!= NULL
5090 && (strncmp (name
, "PARENT", 6) == 0
5091 || strcmp (name
, "REP") == 0
5092 || strncmp (name
, "_parent", 7) == 0
5093 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5096 /* True iff field number FIELD_NUM of structure or union type TYPE
5097 is a variant wrapper. Assumes TYPE is a structure type with at least
5098 FIELD_NUM+1 fields. */
5101 ada_is_variant_part (struct type
*type
, int field_num
)
5103 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5104 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5105 || (is_dynamic_field (type
, field_num
)
5106 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5107 == TYPE_CODE_UNION
)));
5110 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5111 whose discriminants are contained in the record type OUTER_TYPE,
5112 returns the type of the controlling discriminant for the variant. */
5115 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5117 char *name
= ada_variant_discrim_name (var_type
);
5119 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5121 return builtin_type_int
;
5126 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5127 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5128 represents a 'when others' clause; otherwise 0. */
5131 ada_is_others_clause (struct type
*type
, int field_num
)
5133 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5134 return (name
!= NULL
&& name
[0] == 'O');
5137 /* Assuming that TYPE0 is the type of the variant part of a record,
5138 returns the name of the discriminant controlling the variant.
5139 The value is valid until the next call to ada_variant_discrim_name. */
5142 ada_variant_discrim_name (struct type
*type0
)
5144 static char *result
= NULL
;
5145 static size_t result_len
= 0;
5148 const char *discrim_end
;
5149 const char *discrim_start
;
5151 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5152 type
= TYPE_TARGET_TYPE (type0
);
5156 name
= ada_type_name (type
);
5158 if (name
== NULL
|| name
[0] == '\000')
5161 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5164 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5167 if (discrim_end
== name
)
5170 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5173 if (discrim_start
== name
+ 1)
5175 if ((discrim_start
> name
+ 3
5176 && strncmp (discrim_start
- 3, "___", 3) == 0)
5177 || discrim_start
[-1] == '.')
5181 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5182 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5183 result
[discrim_end
- discrim_start
] = '\0';
5187 /* Scan STR for a subtype-encoded number, beginning at position K.
5188 Put the position of the character just past the number scanned in
5189 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5190 Return 1 if there was a valid number at the given position, and 0
5191 otherwise. A "subtype-encoded" number consists of the absolute value
5192 in decimal, followed by the letter 'm' to indicate a negative number.
5193 Assumes 0m does not occur. */
5196 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5200 if (!isdigit (str
[k
]))
5203 /* Do it the hard way so as not to make any assumption about
5204 the relationship of unsigned long (%lu scan format code) and
5207 while (isdigit (str
[k
]))
5209 RU
= RU
* 10 + (str
[k
] - '0');
5216 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5222 /* NOTE on the above: Technically, C does not say what the results of
5223 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5224 number representable as a LONGEST (although either would probably work
5225 in most implementations). When RU>0, the locution in the then branch
5226 above is always equivalent to the negative of RU. */
5233 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5234 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5235 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5238 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5240 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5253 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5262 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5263 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5265 if (val
>= L
&& val
<= U
)
5277 /* FIXME: Lots of redundancy below. Try to consolidate. */
5279 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5280 ARG_TYPE, extract and return the value of one of its (non-static)
5281 fields. FIELDNO says which field. Differs from value_primitive_field
5282 only in that it can handle packed values of arbitrary type. */
5284 static struct value
*
5285 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5286 struct type
*arg_type
)
5290 arg_type
= ada_check_typedef (arg_type
);
5291 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5293 /* Handle packed fields. */
5295 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5297 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5298 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5300 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5301 offset
+ bit_pos
/ 8,
5302 bit_pos
% 8, bit_size
, type
);
5305 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5308 /* Find field with name NAME in object of type TYPE. If found, return 1
5309 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
5310 OFFSET + the byte offset of the field within an object of that type,
5311 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
5312 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
5313 Looks inside wrappers for the field. Returns 0 if field not
5316 find_struct_field (char *name
, struct type
*type
, int offset
,
5317 struct type
**field_type_p
,
5318 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
5322 type
= ada_check_typedef (type
);
5323 *field_type_p
= NULL
;
5324 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
5326 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5328 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
5329 int fld_offset
= offset
+ bit_pos
/ 8;
5330 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5332 if (t_field_name
== NULL
)
5335 else if (field_name_match (t_field_name
, name
))
5337 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
5338 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
5339 *byte_offset_p
= fld_offset
;
5340 *bit_offset_p
= bit_pos
% 8;
5341 *bit_size_p
= bit_size
;
5344 else if (ada_is_wrapper_field (type
, i
))
5346 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
5347 field_type_p
, byte_offset_p
, bit_offset_p
,
5351 else if (ada_is_variant_part (type
, i
))
5354 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5356 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5358 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
5360 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5361 field_type_p
, byte_offset_p
,
5362 bit_offset_p
, bit_size_p
))
5372 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5373 and search in it assuming it has (class) type TYPE.
5374 If found, return value, else return NULL.
5376 Searches recursively through wrapper fields (e.g., '_parent'). */
5378 static struct value
*
5379 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5383 type
= ada_check_typedef (type
);
5385 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5387 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5389 if (t_field_name
== NULL
)
5392 else if (field_name_match (t_field_name
, name
))
5393 return ada_value_primitive_field (arg
, offset
, i
, type
);
5395 else if (ada_is_wrapper_field (type
, i
))
5397 struct value
*v
= /* Do not let indent join lines here. */
5398 ada_search_struct_field (name
, arg
,
5399 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5400 TYPE_FIELD_TYPE (type
, i
));
5405 else if (ada_is_variant_part (type
, i
))
5408 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5409 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5411 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5413 struct value
*v
= ada_search_struct_field
/* Force line break. */
5415 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5416 TYPE_FIELD_TYPE (field_type
, j
));
5425 /* Given ARG, a value of type (pointer or reference to a)*
5426 structure/union, extract the component named NAME from the ultimate
5427 target structure/union and return it as a value with its
5428 appropriate type. If ARG is a pointer or reference and the field
5429 is not packed, returns a reference to the field, otherwise the
5430 value of the field (an lvalue if ARG is an lvalue).
5432 The routine searches for NAME among all members of the structure itself
5433 and (recursively) among all members of any wrapper members
5436 ERR is a name (for use in error messages) that identifies the class
5437 of entity that ARG is supposed to be. ERR may be null, indicating
5438 that on error, the function simply returns NULL, and does not
5439 throw an error. (FIXME: True only if ARG is a pointer or reference
5443 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5445 struct type
*t
, *t1
;
5449 t1
= t
= ada_check_typedef (VALUE_TYPE (arg
));
5450 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5452 t1
= TYPE_TARGET_TYPE (t
);
5458 error ("Bad value type in a %s.", err
);
5460 t1
= ada_check_typedef (t1
);
5461 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5468 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5470 t1
= TYPE_TARGET_TYPE (t
);
5476 error ("Bad value type in a %s.", err
);
5478 t1
= ada_check_typedef (t1
);
5479 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5481 arg
= value_ind (arg
);
5488 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
5493 error ("Attempt to extract a component of a value that is not a %s.",
5498 v
= ada_search_struct_field (name
, arg
, 0, t
);
5501 int bit_offset
, bit_size
, byte_offset
;
5502 struct type
*field_type
;
5505 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5506 address
= value_as_address (arg
);
5508 address
= unpack_pointer (t
, VALUE_CONTENTS (arg
));
5510 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
5511 if (find_struct_field (name
, t1
, 0,
5512 &field_type
, &byte_offset
, &bit_offset
,
5517 arg
= ada_value_ind (arg
);
5518 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
5519 bit_offset
, bit_size
,
5523 v
= value_from_pointer (lookup_reference_type (field_type
),
5524 address
+ byte_offset
);
5528 if (v
== NULL
&& err
!= NULL
)
5529 error ("There is no member named %s.", name
);
5534 /* Given a type TYPE, look up the type of the component of type named NAME.
5535 If DISPP is non-null, add its byte displacement from the beginning of a
5536 structure (pointed to by a value) of type TYPE to *DISPP (does not
5537 work for packed fields).
5539 Matches any field whose name has NAME as a prefix, possibly
5542 TYPE can be either a struct or union. If REFOK, TYPE may also
5543 be a (pointer or reference)+ to a struct or union, and the
5544 ultimate target type will be searched.
5546 Looks recursively into variant clauses and parent types.
5548 If NOERR is nonzero, return NULL if NAME is not suitably defined or
5549 TYPE is not a type of the right kind. */
5551 static struct type
*
5552 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
5553 int noerr
, int *dispp
)
5560 if (refok
&& type
!= NULL
)
5563 type
= ada_check_typedef (type
);
5564 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5565 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5567 type
= TYPE_TARGET_TYPE (type
);
5571 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
5572 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
5578 target_terminal_ours ();
5579 gdb_flush (gdb_stdout
);
5580 fprintf_unfiltered (gdb_stderr
, "Type ");
5582 fprintf_unfiltered (gdb_stderr
, "(null)");
5584 type_print (type
, "", gdb_stderr
, -1);
5585 error (" is not a structure or union type");
5589 type
= to_static_fixed_type (type
);
5591 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5593 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5597 if (t_field_name
== NULL
)
5600 else if (field_name_match (t_field_name
, name
))
5603 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5604 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5607 else if (ada_is_wrapper_field (type
, i
))
5610 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5615 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5620 else if (ada_is_variant_part (type
, i
))
5623 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5625 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5628 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5633 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5644 target_terminal_ours ();
5645 gdb_flush (gdb_stdout
);
5646 fprintf_unfiltered (gdb_stderr
, "Type ");
5647 type_print (type
, "", gdb_stderr
, -1);
5648 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5649 error ("%s", name
== NULL
? "<null>" : name
);
5655 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5656 within a value of type OUTER_TYPE that is stored in GDB at
5657 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5658 numbering from 0) is applicable. Returns -1 if none are. */
5661 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5662 char *outer_valaddr
)
5667 struct type
*discrim_type
;
5668 char *discrim_name
= ada_variant_discrim_name (var_type
);
5669 LONGEST discrim_val
;
5673 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
5674 if (discrim_type
== NULL
)
5676 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5679 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5681 if (ada_is_others_clause (var_type
, i
))
5683 else if (ada_in_variant (discrim_val
, var_type
, i
))
5687 return others_clause
;
5692 /* Dynamic-Sized Records */
5694 /* Strategy: The type ostensibly attached to a value with dynamic size
5695 (i.e., a size that is not statically recorded in the debugging
5696 data) does not accurately reflect the size or layout of the value.
5697 Our strategy is to convert these values to values with accurate,
5698 conventional types that are constructed on the fly. */
5700 /* There is a subtle and tricky problem here. In general, we cannot
5701 determine the size of dynamic records without its data. However,
5702 the 'struct value' data structure, which GDB uses to represent
5703 quantities in the inferior process (the target), requires the size
5704 of the type at the time of its allocation in order to reserve space
5705 for GDB's internal copy of the data. That's why the
5706 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5707 rather than struct value*s.
5709 However, GDB's internal history variables ($1, $2, etc.) are
5710 struct value*s containing internal copies of the data that are not, in
5711 general, the same as the data at their corresponding addresses in
5712 the target. Fortunately, the types we give to these values are all
5713 conventional, fixed-size types (as per the strategy described
5714 above), so that we don't usually have to perform the
5715 'to_fixed_xxx_type' conversions to look at their values.
5716 Unfortunately, there is one exception: if one of the internal
5717 history variables is an array whose elements are unconstrained
5718 records, then we will need to create distinct fixed types for each
5719 element selected. */
5721 /* The upshot of all of this is that many routines take a (type, host
5722 address, target address) triple as arguments to represent a value.
5723 The host address, if non-null, is supposed to contain an internal
5724 copy of the relevant data; otherwise, the program is to consult the
5725 target at the target address. */
5727 /* Assuming that VAL0 represents a pointer value, the result of
5728 dereferencing it. Differs from value_ind in its treatment of
5729 dynamic-sized types. */
5732 ada_value_ind (struct value
*val0
)
5734 struct value
*val
= unwrap_value (value_ind (val0
));
5735 return ada_to_fixed_value (val
);
5738 /* The value resulting from dereferencing any "reference to"
5739 qualifiers on VAL0. */
5741 static struct value
*
5742 ada_coerce_ref (struct value
*val0
)
5744 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5746 struct value
*val
= val0
;
5748 val
= unwrap_value (val
);
5749 return ada_to_fixed_value (val
);
5755 /* Return OFF rounded upward if necessary to a multiple of
5756 ALIGNMENT (a power of 2). */
5759 align_value (unsigned int off
, unsigned int alignment
)
5761 return (off
+ alignment
- 1) & ~(alignment
- 1);
5764 /* Return the bit alignment required for field #F of template type TYPE. */
5767 field_alignment (struct type
*type
, int f
)
5769 const char *name
= TYPE_FIELD_NAME (type
, f
);
5770 int len
= (name
== NULL
) ? 0 : strlen (name
);
5773 if (!isdigit (name
[len
- 1]))
5776 if (isdigit (name
[len
- 2]))
5777 align_offset
= len
- 2;
5779 align_offset
= len
- 1;
5781 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
5782 return TARGET_CHAR_BIT
;
5784 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5787 /* Find a symbol named NAME. Ignores ambiguity. */
5790 ada_find_any_symbol (const char *name
)
5794 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
5795 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5798 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
5802 /* Find a type named NAME. Ignores ambiguity. */
5805 ada_find_any_type (const char *name
)
5807 struct symbol
*sym
= ada_find_any_symbol (name
);
5810 return SYMBOL_TYPE (sym
);
5815 /* Given a symbol NAME and its associated BLOCK, search all symbols
5816 for its ___XR counterpart, which is the ``renaming'' symbol
5817 associated to NAME. Return this symbol if found, return
5821 ada_find_renaming_symbol (const char *name
, struct block
*block
)
5823 const struct symbol
*function_sym
= block_function (block
);
5826 if (function_sym
!= NULL
)
5828 /* If the symbol is defined inside a function, NAME is not fully
5829 qualified. This means we need to prepend the function name
5830 as well as adding the ``___XR'' suffix to build the name of
5831 the associated renaming symbol. */
5832 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
5833 const int function_name_len
= strlen (function_name
);
5834 const int rename_len
= function_name_len
+ 2 /* "__" */
5835 + strlen (name
) + 6 /* "___XR\0" */ ;
5837 /* Library-level functions are a special case, as GNAT adds
5838 a ``_ada_'' prefix to the function name to avoid namespace
5839 pollution. However, the renaming symbol themselves do not
5840 have this prefix, so we need to skip this prefix if present. */
5841 if (function_name_len
> 5 /* "_ada_" */
5842 && strstr (function_name
, "_ada_") == function_name
)
5843 function_name
= function_name
+ 5;
5845 rename
= (char *) alloca (rename_len
* sizeof (char));
5846 sprintf (rename
, "%s__%s___XR", function_name
, name
);
5850 const int rename_len
= strlen (name
) + 6;
5851 rename
= (char *) alloca (rename_len
* sizeof (char));
5852 sprintf (rename
, "%s___XR", name
);
5855 return ada_find_any_symbol (rename
);
5858 /* Because of GNAT encoding conventions, several GDB symbols may match a
5859 given type name. If the type denoted by TYPE0 is to be preferred to
5860 that of TYPE1 for purposes of type printing, return non-zero;
5861 otherwise return 0. */
5864 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5868 else if (type0
== NULL
)
5870 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5872 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5874 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
5876 else if (ada_is_packed_array_type (type0
))
5878 else if (ada_is_array_descriptor_type (type0
)
5879 && !ada_is_array_descriptor_type (type1
))
5881 else if (ada_renaming_type (type0
) != NULL
5882 && ada_renaming_type (type1
) == NULL
)
5887 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5888 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5891 ada_type_name (struct type
*type
)
5895 else if (TYPE_NAME (type
) != NULL
)
5896 return TYPE_NAME (type
);
5898 return TYPE_TAG_NAME (type
);
5901 /* Find a parallel type to TYPE whose name is formed by appending
5902 SUFFIX to the name of TYPE. */
5905 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5908 static size_t name_len
= 0;
5910 char *typename
= ada_type_name (type
);
5912 if (typename
== NULL
)
5915 len
= strlen (typename
);
5917 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5919 strcpy (name
, typename
);
5920 strcpy (name
+ len
, suffix
);
5922 return ada_find_any_type (name
);
5926 /* If TYPE is a variable-size record type, return the corresponding template
5927 type describing its fields. Otherwise, return NULL. */
5929 static struct type
*
5930 dynamic_template_type (struct type
*type
)
5932 type
= ada_check_typedef (type
);
5934 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5935 || ada_type_name (type
) == NULL
)
5939 int len
= strlen (ada_type_name (type
));
5940 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
5943 return ada_find_parallel_type (type
, "___XVE");
5947 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5948 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5951 is_dynamic_field (struct type
*templ_type
, int field_num
)
5953 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5955 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5956 && strstr (name
, "___XVL") != NULL
;
5959 /* The index of the variant field of TYPE, or -1 if TYPE does not
5960 represent a variant record type. */
5963 variant_field_index (struct type
*type
)
5967 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5970 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
5972 if (ada_is_variant_part (type
, f
))
5978 /* A record type with no fields. */
5980 static struct type
*
5981 empty_record (struct objfile
*objfile
)
5983 struct type
*type
= alloc_type (objfile
);
5984 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5985 TYPE_NFIELDS (type
) = 0;
5986 TYPE_FIELDS (type
) = NULL
;
5987 TYPE_NAME (type
) = "<empty>";
5988 TYPE_TAG_NAME (type
) = NULL
;
5989 TYPE_FLAGS (type
) = 0;
5990 TYPE_LENGTH (type
) = 0;
5994 /* An ordinary record type (with fixed-length fields) that describes
5995 the value of type TYPE at VALADDR or ADDRESS (see comments at
5996 the beginning of this section) VAL according to GNAT conventions.
5997 DVAL0 should describe the (portion of a) record that contains any
5998 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
5999 an outer-level type (i.e., as opposed to a branch of a variant.) A
6000 variant field (unless unchecked) is replaced by a particular branch
6003 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6004 length are not statically known are discarded. As a consequence,
6005 VALADDR, ADDRESS and DVAL0 are ignored.
6007 NOTE: Limitations: For now, we assume that dynamic fields and
6008 variants occupy whole numbers of bytes. However, they need not be
6012 ada_template_to_fixed_record_type_1 (struct type
*type
, char *valaddr
,
6013 CORE_ADDR address
, struct value
*dval0
,
6014 int keep_dynamic_fields
)
6016 struct value
*mark
= value_mark ();
6019 int nfields
, bit_len
;
6022 int fld_bit_len
, bit_incr
;
6025 /* Compute the number of fields in this record type that are going
6026 to be processed: unless keep_dynamic_fields, this includes only
6027 fields whose position and length are static will be processed. */
6028 if (keep_dynamic_fields
)
6029 nfields
= TYPE_NFIELDS (type
);
6033 while (nfields
< TYPE_NFIELDS (type
)
6034 && !ada_is_variant_part (type
, nfields
)
6035 && !is_dynamic_field (type
, nfields
))
6039 rtype
= alloc_type (TYPE_OBJFILE (type
));
6040 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6041 INIT_CPLUS_SPECIFIC (rtype
);
6042 TYPE_NFIELDS (rtype
) = nfields
;
6043 TYPE_FIELDS (rtype
) = (struct field
*)
6044 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6045 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6046 TYPE_NAME (rtype
) = ada_type_name (type
);
6047 TYPE_TAG_NAME (rtype
) = NULL
;
6048 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6054 for (f
= 0; f
< nfields
; f
+= 1)
6056 off
= align_value (off
, field_alignment (type
, f
))
6057 + TYPE_FIELD_BITPOS (type
, f
);
6058 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6059 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6061 if (ada_is_variant_part (type
, f
))
6064 fld_bit_len
= bit_incr
= 0;
6066 else if (is_dynamic_field (type
, f
))
6069 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6073 TYPE_FIELD_TYPE (rtype
, f
) =
6076 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6077 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6078 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6079 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6080 bit_incr
= fld_bit_len
=
6081 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6085 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6086 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6087 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6088 bit_incr
= fld_bit_len
=
6089 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6091 bit_incr
= fld_bit_len
=
6092 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6094 if (off
+ fld_bit_len
> bit_len
)
6095 bit_len
= off
+ fld_bit_len
;
6097 TYPE_LENGTH (rtype
) =
6098 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6101 /* We handle the variant part, if any, at the end because of certain
6102 odd cases in which it is re-ordered so as NOT the last field of
6103 the record. This can happen in the presence of representation
6105 if (variant_field
>= 0)
6107 struct type
*branch_type
;
6109 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6112 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6117 to_fixed_variant_branch_type
6118 (TYPE_FIELD_TYPE (type
, variant_field
),
6119 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6120 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6121 if (branch_type
== NULL
)
6123 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6124 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6125 TYPE_NFIELDS (rtype
) -= 1;
6129 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6130 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6132 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6134 if (off
+ fld_bit_len
> bit_len
)
6135 bit_len
= off
+ fld_bit_len
;
6136 TYPE_LENGTH (rtype
) =
6137 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6141 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6143 value_free_to_mark (mark
);
6144 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6145 error ("record type with dynamic size is larger than varsize-limit");
6149 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6152 static struct type
*
6153 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6154 CORE_ADDR address
, struct value
*dval0
)
6156 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6160 /* An ordinary record type in which ___XVL-convention fields and
6161 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6162 static approximations, containing all possible fields. Uses
6163 no runtime values. Useless for use in values, but that's OK,
6164 since the results are used only for type determinations. Works on both
6165 structs and unions. Representation note: to save space, we memorize
6166 the result of this function in the TYPE_TARGET_TYPE of the
6169 static struct type
*
6170 template_to_static_fixed_type (struct type
*type0
)
6176 if (TYPE_TARGET_TYPE (type0
) != NULL
)
6177 return TYPE_TARGET_TYPE (type0
);
6179 nfields
= TYPE_NFIELDS (type0
);
6182 for (f
= 0; f
< nfields
; f
+= 1)
6184 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
6185 struct type
*new_type
;
6187 if (is_dynamic_field (type0
, f
))
6188 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
6190 new_type
= to_static_fixed_type (field_type
);
6191 if (type
== type0
&& new_type
!= field_type
)
6193 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
6194 TYPE_CODE (type
) = TYPE_CODE (type0
);
6195 INIT_CPLUS_SPECIFIC (type
);
6196 TYPE_NFIELDS (type
) = nfields
;
6197 TYPE_FIELDS (type
) = (struct field
*)
6198 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6199 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
6200 sizeof (struct field
) * nfields
);
6201 TYPE_NAME (type
) = ada_type_name (type0
);
6202 TYPE_TAG_NAME (type
) = NULL
;
6203 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
6204 TYPE_LENGTH (type
) = 0;
6206 TYPE_FIELD_TYPE (type
, f
) = new_type
;
6207 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
6212 /* Given an object of type TYPE whose contents are at VALADDR and
6213 whose address in memory is ADDRESS, returns a revision of TYPE --
6214 a non-dynamic-sized record with a variant part -- in which
6215 the variant part is replaced with the appropriate branch. Looks
6216 for discriminant values in DVAL0, which can be NULL if the record
6217 contains the necessary discriminant values. */
6219 static struct type
*
6220 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6221 CORE_ADDR address
, struct value
*dval0
)
6223 struct value
*mark
= value_mark ();
6226 struct type
*branch_type
;
6227 int nfields
= TYPE_NFIELDS (type
);
6228 int variant_field
= variant_field_index (type
);
6230 if (variant_field
== -1)
6234 dval
= value_from_contents_and_address (type
, valaddr
, address
);
6238 rtype
= alloc_type (TYPE_OBJFILE (type
));
6239 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6240 INIT_CPLUS_SPECIFIC (rtype
);
6241 TYPE_NFIELDS (rtype
) = nfields
;
6242 TYPE_FIELDS (rtype
) =
6243 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6244 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6245 sizeof (struct field
) * nfields
);
6246 TYPE_NAME (rtype
) = ada_type_name (type
);
6247 TYPE_TAG_NAME (rtype
) = NULL
;
6248 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6249 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6251 branch_type
= to_fixed_variant_branch_type
6252 (TYPE_FIELD_TYPE (type
, variant_field
),
6253 cond_offset_host (valaddr
,
6254 TYPE_FIELD_BITPOS (type
, variant_field
)
6256 cond_offset_target (address
,
6257 TYPE_FIELD_BITPOS (type
, variant_field
)
6258 / TARGET_CHAR_BIT
), dval
);
6259 if (branch_type
== NULL
)
6262 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
6263 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6264 TYPE_NFIELDS (rtype
) -= 1;
6268 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6269 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6270 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
6271 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6273 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
6275 value_free_to_mark (mark
);
6279 /* An ordinary record type (with fixed-length fields) that describes
6280 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6281 beginning of this section]. Any necessary discriminants' values
6282 should be in DVAL, a record value; it may be NULL if the object
6283 at ADDR itself contains any necessary discriminant values.
6284 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6285 values from the record are needed. Except in the case that DVAL,
6286 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6287 unchecked) is replaced by a particular branch of the variant.
6289 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6290 is questionable and may be removed. It can arise during the
6291 processing of an unconstrained-array-of-record type where all the
6292 variant branches have exactly the same size. This is because in
6293 such cases, the compiler does not bother to use the XVS convention
6294 when encoding the record. I am currently dubious of this
6295 shortcut and suspect the compiler should be altered. FIXME. */
6297 static struct type
*
6298 to_fixed_record_type (struct type
*type0
, char *valaddr
,
6299 CORE_ADDR address
, struct value
*dval
)
6301 struct type
*templ_type
;
6303 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6306 templ_type
= dynamic_template_type (type0
);
6308 if (templ_type
!= NULL
)
6309 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6310 else if (variant_field_index (type0
) >= 0)
6312 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
6314 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
6319 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
6325 /* An ordinary record type (with fixed-length fields) that describes
6326 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6327 union type. Any necessary discriminants' values should be in DVAL,
6328 a record value. That is, this routine selects the appropriate
6329 branch of the union at ADDR according to the discriminant value
6330 indicated in the union's type name. */
6332 static struct type
*
6333 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6334 CORE_ADDR address
, struct value
*dval
)
6337 struct type
*templ_type
;
6338 struct type
*var_type
;
6340 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6341 var_type
= TYPE_TARGET_TYPE (var_type0
);
6343 var_type
= var_type0
;
6345 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6347 if (templ_type
!= NULL
)
6348 var_type
= templ_type
;
6351 ada_which_variant_applies (var_type
,
6352 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6355 return empty_record (TYPE_OBJFILE (var_type
));
6356 else if (is_dynamic_field (var_type
, which
))
6357 return to_fixed_record_type
6358 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6359 valaddr
, address
, dval
);
6360 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
6362 to_fixed_record_type
6363 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6365 return TYPE_FIELD_TYPE (var_type
, which
);
6368 /* Assuming that TYPE0 is an array type describing the type of a value
6369 at ADDR, and that DVAL describes a record containing any
6370 discriminants used in TYPE0, returns a type for the value that
6371 contains no dynamic components (that is, no components whose sizes
6372 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6373 true, gives an error message if the resulting type's size is over
6376 static struct type
*
6377 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6380 struct type
*index_type_desc
;
6381 struct type
*result
;
6383 if (ada_is_packed_array_type (type0
) /* revisit? */
6384 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
6387 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6388 if (index_type_desc
== NULL
)
6390 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
6391 /* NOTE: elt_type---the fixed version of elt_type0---should never
6392 depend on the contents of the array in properly constructed
6394 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6396 if (elt_type0
== elt_type
)
6399 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6400 elt_type
, TYPE_INDEX_TYPE (type0
));
6405 struct type
*elt_type0
;
6408 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6409 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6411 /* NOTE: result---the fixed version of elt_type0---should never
6412 depend on the contents of the array in properly constructed
6414 result
= ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
);
6415 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6417 struct type
*range_type
=
6418 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6419 dval
, TYPE_OBJFILE (type0
));
6420 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6421 result
, range_type
);
6423 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6424 error ("array type with dynamic size is larger than varsize-limit");
6427 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
6432 /* A standard type (containing no dynamically sized components)
6433 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6434 DVAL describes a record containing any discriminants used in TYPE0,
6435 and may be NULL if there are none, or if the object of type TYPE at
6436 ADDRESS or in VALADDR contains these discriminants. */
6439 ada_to_fixed_type (struct type
*type
, char *valaddr
,
6440 CORE_ADDR address
, struct value
*dval
)
6442 type
= ada_check_typedef (type
);
6443 switch (TYPE_CODE (type
))
6447 case TYPE_CODE_STRUCT
:
6449 struct type
*static_type
= to_static_fixed_type (type
);
6450 if (ada_is_tagged_type (static_type
, 0))
6452 struct type
*real_type
=
6453 type_from_tag (value_tag_from_contents_and_address (static_type
,
6456 if (real_type
!= NULL
)
6459 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6461 case TYPE_CODE_ARRAY
:
6462 return to_fixed_array_type (type
, dval
, 1);
6463 case TYPE_CODE_UNION
:
6467 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6471 /* A standard (static-sized) type corresponding as well as possible to
6472 TYPE0, but based on no runtime data. */
6474 static struct type
*
6475 to_static_fixed_type (struct type
*type0
)
6482 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6485 type0
= ada_check_typedef (type0
);
6487 switch (TYPE_CODE (type0
))
6491 case TYPE_CODE_STRUCT
:
6492 type
= dynamic_template_type (type0
);
6494 return template_to_static_fixed_type (type
);
6496 return template_to_static_fixed_type (type0
);
6497 case TYPE_CODE_UNION
:
6498 type
= ada_find_parallel_type (type0
, "___XVU");
6500 return template_to_static_fixed_type (type
);
6502 return template_to_static_fixed_type (type0
);
6506 /* A static approximation of TYPE with all type wrappers removed. */
6508 static struct type
*
6509 static_unwrap_type (struct type
*type
)
6511 if (ada_is_aligner_type (type
))
6513 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
6514 if (ada_type_name (type1
) == NULL
)
6515 TYPE_NAME (type1
) = ada_type_name (type
);
6517 return static_unwrap_type (type1
);
6521 struct type
*raw_real_type
= ada_get_base_type (type
);
6522 if (raw_real_type
== type
)
6525 return to_static_fixed_type (raw_real_type
);
6529 /* In some cases, incomplete and private types require
6530 cross-references that are not resolved as records (for example,
6532 type FooP is access Foo;
6534 type Foo is array ...;
6535 ). In these cases, since there is no mechanism for producing
6536 cross-references to such types, we instead substitute for FooP a
6537 stub enumeration type that is nowhere resolved, and whose tag is
6538 the name of the actual type. Call these types "non-record stubs". */
6540 /* A type equivalent to TYPE that is not a non-record stub, if one
6541 exists, otherwise TYPE. */
6544 ada_check_typedef (struct type
*type
)
6546 CHECK_TYPEDEF (type
);
6547 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6548 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6549 || TYPE_TAG_NAME (type
) == NULL
)
6553 char *name
= TYPE_TAG_NAME (type
);
6554 struct type
*type1
= ada_find_any_type (name
);
6555 return (type1
== NULL
) ? type
: type1
;
6559 /* A value representing the data at VALADDR/ADDRESS as described by
6560 type TYPE0, but with a standard (static-sized) type that correctly
6561 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6562 type, then return VAL0 [this feature is simply to avoid redundant
6563 creation of struct values]. */
6565 static struct value
*
6566 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
6569 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
6570 if (type
== type0
&& val0
!= NULL
)
6573 return value_from_contents_and_address (type
, 0, address
);
6576 /* A value representing VAL, but with a standard (static-sized) type
6577 that correctly describes it. Does not necessarily create a new
6580 static struct value
*
6581 ada_to_fixed_value (struct value
*val
)
6583 return ada_to_fixed_value_create (VALUE_TYPE (val
),
6584 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6588 /* A value representing VAL, but with a standard (static-sized) type
6589 chosen to approximate the real type of VAL as well as possible, but
6590 without consulting any runtime values. For Ada dynamic-sized
6591 types, therefore, the type of the result is likely to be inaccurate. */
6594 ada_to_static_fixed_value (struct value
*val
)
6597 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6598 if (type
== VALUE_TYPE (val
))
6601 return coerce_unspec_val_to_type (val
, type
);
6607 /* Table mapping attribute numbers to names.
6608 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
6610 static const char *attribute_names
[] = {
6628 ada_attribute_name (enum exp_opcode n
)
6630 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
6631 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
6633 return attribute_names
[0];
6636 /* Evaluate the 'POS attribute applied to ARG. */
6639 pos_atr (struct value
*arg
)
6641 struct type
*type
= VALUE_TYPE (arg
);
6643 if (!discrete_type_p (type
))
6644 error ("'POS only defined on discrete types");
6646 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6649 LONGEST v
= value_as_long (arg
);
6651 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6653 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6656 error ("enumeration value is invalid: can't find 'POS");
6659 return value_as_long (arg
);
6662 static struct value
*
6663 value_pos_atr (struct value
*arg
)
6665 return value_from_longest (builtin_type_int
, pos_atr (arg
));
6668 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6670 static struct value
*
6671 value_val_atr (struct type
*type
, struct value
*arg
)
6673 if (!discrete_type_p (type
))
6674 error ("'VAL only defined on discrete types");
6675 if (!integer_type_p (VALUE_TYPE (arg
)))
6676 error ("'VAL requires integral argument");
6678 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6680 long pos
= value_as_long (arg
);
6681 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6682 error ("argument to 'VAL out of range");
6683 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6686 return value_from_longest (type
, value_as_long (arg
));
6692 /* True if TYPE appears to be an Ada character type.
6693 [At the moment, this is true only for Character and Wide_Character;
6694 It is a heuristic test that could stand improvement]. */
6697 ada_is_character_type (struct type
*type
)
6699 const char *name
= ada_type_name (type
);
6702 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6703 || TYPE_CODE (type
) == TYPE_CODE_INT
6704 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6705 && (strcmp (name
, "character") == 0
6706 || strcmp (name
, "wide_character") == 0
6707 || strcmp (name
, "unsigned char") == 0);
6710 /* True if TYPE appears to be an Ada string type. */
6713 ada_is_string_type (struct type
*type
)
6715 type
= ada_check_typedef (type
);
6717 && TYPE_CODE (type
) != TYPE_CODE_PTR
6718 && (ada_is_simple_array_type (type
)
6719 || ada_is_array_descriptor_type (type
))
6720 && ada_array_arity (type
) == 1)
6722 struct type
*elttype
= ada_array_element_type (type
, 1);
6724 return ada_is_character_type (elttype
);
6731 /* True if TYPE is a struct type introduced by the compiler to force the
6732 alignment of a value. Such types have a single field with a
6733 distinctive name. */
6736 ada_is_aligner_type (struct type
*type
)
6738 type
= ada_check_typedef (type
);
6739 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6740 && TYPE_NFIELDS (type
) == 1
6741 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
6744 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6745 the parallel type. */
6748 ada_get_base_type (struct type
*raw_type
)
6750 struct type
*real_type_namer
;
6751 struct type
*raw_real_type
;
6753 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6756 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6757 if (real_type_namer
== NULL
6758 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6759 || TYPE_NFIELDS (real_type_namer
) != 1)
6762 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6763 if (raw_real_type
== NULL
)
6766 return raw_real_type
;
6769 /* The type of value designated by TYPE, with all aligners removed. */
6772 ada_aligned_type (struct type
*type
)
6774 if (ada_is_aligner_type (type
))
6775 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6777 return ada_get_base_type (type
);
6781 /* The address of the aligned value in an object at address VALADDR
6782 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6785 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6787 if (ada_is_aligner_type (type
))
6788 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6790 TYPE_FIELD_BITPOS (type
,
6791 0) / TARGET_CHAR_BIT
);
6798 /* The printed representation of an enumeration literal with encoded
6799 name NAME. The value is good to the next call of ada_enum_name. */
6801 ada_enum_name (const char *name
)
6803 static char *result
;
6804 static size_t result_len
= 0;
6807 /* First, unqualify the enumeration name:
6808 1. Search for the last '.' character. If we find one, then skip
6809 all the preceeding characters, the unqualified name starts
6810 right after that dot.
6811 2. Otherwise, we may be debugging on a target where the compiler
6812 translates dots into "__". Search forward for double underscores,
6813 but stop searching when we hit an overloading suffix, which is
6814 of the form "__" followed by digits. */
6816 tmp
= strrchr (name
, '.');
6821 while ((tmp
= strstr (name
, "__")) != NULL
)
6823 if (isdigit (tmp
[2]))
6833 if (name
[1] == 'U' || name
[1] == 'W')
6835 if (sscanf (name
+ 2, "%x", &v
) != 1)
6841 GROW_VECT (result
, result_len
, 16);
6842 if (isascii (v
) && isprint (v
))
6843 sprintf (result
, "'%c'", v
);
6844 else if (name
[1] == 'U')
6845 sprintf (result
, "[\"%02x\"]", v
);
6847 sprintf (result
, "[\"%04x\"]", v
);
6853 tmp
= strstr (name
, "__");
6855 tmp
= strstr (name
, "$");
6858 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
6859 strncpy (result
, name
, tmp
- name
);
6860 result
[tmp
- name
] = '\0';
6868 static struct value
*
6869 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6872 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6873 (expect_type
, exp
, pos
, noside
);
6876 /* Evaluate the subexpression of EXP starting at *POS as for
6877 evaluate_type, updating *POS to point just past the evaluated
6880 static struct value
*
6881 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6883 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6884 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6887 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6890 static struct value
*
6891 unwrap_value (struct value
*val
)
6893 struct type
*type
= ada_check_typedef (VALUE_TYPE (val
));
6894 if (ada_is_aligner_type (type
))
6896 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6897 NULL
, "internal structure");
6898 struct type
*val_type
= ada_check_typedef (VALUE_TYPE (v
));
6899 if (ada_type_name (val_type
) == NULL
)
6900 TYPE_NAME (val_type
) = ada_type_name (type
);
6902 return unwrap_value (v
);
6906 struct type
*raw_real_type
=
6907 ada_check_typedef (ada_get_base_type (type
));
6909 if (type
== raw_real_type
)
6913 coerce_unspec_val_to_type
6914 (val
, ada_to_fixed_type (raw_real_type
, 0,
6915 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6920 static struct value
*
6921 cast_to_fixed (struct type
*type
, struct value
*arg
)
6925 if (type
== VALUE_TYPE (arg
))
6927 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6928 val
= ada_float_to_fixed (type
,
6929 ada_fixed_to_float (VALUE_TYPE (arg
),
6930 value_as_long (arg
)));
6934 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6935 val
= ada_float_to_fixed (type
, argd
);
6938 return value_from_longest (type
, val
);
6941 static struct value
*
6942 cast_from_fixed_to_double (struct value
*arg
)
6944 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6945 value_as_long (arg
));
6946 return value_from_double (builtin_type_double
, val
);
6949 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6950 return the converted value. */
6952 static struct value
*
6953 coerce_for_assign (struct type
*type
, struct value
*val
)
6955 struct type
*type2
= VALUE_TYPE (val
);
6959 type2
= ada_check_typedef (type2
);
6960 type
= ada_check_typedef (type
);
6962 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6963 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6965 val
= ada_value_ind (val
);
6966 type2
= VALUE_TYPE (val
);
6969 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6970 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6972 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6973 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6974 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6975 error ("Incompatible types in assignment");
6976 VALUE_TYPE (val
) = type
;
6981 static struct value
*
6982 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
6985 struct type
*type1
, *type2
;
6990 type1
= base_type (ada_check_typedef (VALUE_TYPE (arg1
)));
6991 type2
= base_type (ada_check_typedef (VALUE_TYPE (arg2
)));
6993 if (TYPE_CODE (type1
) != TYPE_CODE_INT
6994 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
6995 return value_binop (arg1
, arg2
, op
);
7004 return value_binop (arg1
, arg2
, op
);
7007 v2
= value_as_long (arg2
);
7009 error ("second operand of %s must not be zero.", op_string (op
));
7011 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7012 return value_binop (arg1
, arg2
, op
);
7014 v1
= value_as_long (arg1
);
7019 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7020 v
+= v
> 0 ? -1 : 1;
7028 /* Should not reach this point. */
7032 val
= allocate_value (type1
);
7033 store_unsigned_integer (VALUE_CONTENTS_RAW (val
),
7034 TYPE_LENGTH (VALUE_TYPE (val
)), v
);
7039 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7041 if (ada_is_direct_array_type (VALUE_TYPE (arg1
))
7042 || ada_is_direct_array_type (VALUE_TYPE (arg2
)))
7044 arg1
= ada_coerce_to_simple_array (arg1
);
7045 arg2
= ada_coerce_to_simple_array (arg2
);
7046 if (TYPE_CODE (VALUE_TYPE (arg1
)) != TYPE_CODE_ARRAY
7047 || TYPE_CODE (VALUE_TYPE (arg2
)) != TYPE_CODE_ARRAY
)
7048 error ("Attempt to compare array with non-array");
7049 /* FIXME: The following works only for types whose
7050 representations use all bits (no padding or undefined bits)
7051 and do not have user-defined equality. */
7053 TYPE_LENGTH (VALUE_TYPE (arg1
)) == TYPE_LENGTH (VALUE_TYPE (arg2
))
7054 && memcmp (VALUE_CONTENTS (arg1
), VALUE_CONTENTS (arg2
),
7055 TYPE_LENGTH (VALUE_TYPE (arg1
))) == 0;
7057 return value_equal (arg1
, arg2
);
7061 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
7062 int *pos
, enum noside noside
)
7065 int tem
, tem2
, tem3
;
7067 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
7070 struct value
**argvec
;
7074 op
= exp
->elts
[pc
].opcode
;
7081 unwrap_value (evaluate_subexp_standard
7082 (expect_type
, exp
, pos
, noside
));
7086 struct value
*result
;
7088 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
7089 /* The result type will have code OP_STRING, bashed there from
7090 OP_ARRAY. Bash it back. */
7091 if (TYPE_CODE (VALUE_TYPE (result
)) == TYPE_CODE_STRING
)
7092 TYPE_CODE (VALUE_TYPE (result
)) = TYPE_CODE_ARRAY
;
7098 type
= exp
->elts
[pc
+ 1].type
;
7099 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
7100 if (noside
== EVAL_SKIP
)
7102 if (type
!= ada_check_typedef (VALUE_TYPE (arg1
)))
7104 if (ada_is_fixed_point_type (type
))
7105 arg1
= cast_to_fixed (type
, arg1
);
7106 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7107 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
7108 else if (VALUE_LVAL (arg1
) == lval_memory
)
7110 /* This is in case of the really obscure (and undocumented,
7111 but apparently expected) case of (Foo) Bar.all, where Bar
7112 is an integer constant and Foo is a dynamic-sized type.
7113 If we don't do this, ARG1 will simply be relabeled with
7115 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7116 return value_zero (to_static_fixed_type (type
), not_lval
);
7118 ada_to_fixed_value_create
7119 (type
, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
7122 arg1
= value_cast (type
, arg1
);
7128 type
= exp
->elts
[pc
+ 1].type
;
7129 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
7132 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7133 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
7134 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7136 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7137 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
7138 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
7140 ("Fixed-point values must be assigned to fixed-point variables");
7142 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
7143 return ada_value_assign (arg1
, arg2
);
7146 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7147 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7148 if (noside
== EVAL_SKIP
)
7150 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
7151 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
7152 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
7153 error ("Operands of fixed-point addition must have the same type");
7154 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
7157 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7158 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7159 if (noside
== EVAL_SKIP
)
7161 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
7162 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
7163 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
7164 error ("Operands of fixed-point subtraction must have the same type");
7165 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
7169 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7170 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7171 if (noside
== EVAL_SKIP
)
7173 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7174 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7175 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7178 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7179 arg1
= cast_from_fixed_to_double (arg1
);
7180 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
7181 arg2
= cast_from_fixed_to_double (arg2
);
7182 return ada_value_binop (arg1
, arg2
, op
);
7187 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7188 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7189 if (noside
== EVAL_SKIP
)
7191 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7192 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7193 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7195 return ada_value_binop (arg1
, arg2
, op
);
7198 case BINOP_NOTEQUAL
:
7199 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7200 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
7201 if (noside
== EVAL_SKIP
)
7203 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7206 tem
= ada_value_equal (arg1
, arg2
);
7207 if (op
== BINOP_NOTEQUAL
)
7209 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
7212 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7213 if (noside
== EVAL_SKIP
)
7215 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
7216 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
7218 return value_neg (arg1
);
7222 if (noside
== EVAL_SKIP
)
7227 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
7228 /* Only encountered when an unresolved symbol occurs in a
7229 context other than a function call, in which case, it is
7231 error ("Unexpected unresolved symbol, %s, during evaluation",
7232 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
7233 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7237 (to_static_fixed_type
7238 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7244 unwrap_value (evaluate_subexp_standard
7245 (expect_type
, exp
, pos
, noside
));
7246 return ada_to_fixed_value (arg1
);
7252 /* Allocate arg vector, including space for the function to be
7253 called in argvec[0] and a terminating NULL. */
7254 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7256 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
7258 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
7259 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
7260 error ("Unexpected unresolved symbol, %s, during evaluation",
7261 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
7264 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7265 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7268 if (noside
== EVAL_SKIP
)
7272 if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec
[0]))))
7273 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7274 else if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
7275 || (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_ARRAY
7276 && VALUE_LVAL (argvec
[0]) == lval_memory
))
7277 argvec
[0] = value_addr (argvec
[0]);
7279 type
= ada_check_typedef (VALUE_TYPE (argvec
[0]));
7280 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7282 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
7284 case TYPE_CODE_FUNC
:
7285 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7287 case TYPE_CODE_ARRAY
:
7289 case TYPE_CODE_STRUCT
:
7290 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7291 argvec
[0] = ada_value_ind (argvec
[0]);
7292 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7295 error ("cannot subscript or call something of type `%s'",
7296 ada_type_name (VALUE_TYPE (argvec
[0])));
7301 switch (TYPE_CODE (type
))
7303 case TYPE_CODE_FUNC
:
7304 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7305 return allocate_value (TYPE_TARGET_TYPE (type
));
7306 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7307 case TYPE_CODE_STRUCT
:
7311 arity
= ada_array_arity (type
);
7312 type
= ada_array_element_type (type
, nargs
);
7314 error ("cannot subscript or call a record");
7316 error ("wrong number of subscripts; expecting %d", arity
);
7317 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7318 return allocate_value (ada_aligned_type (type
));
7320 unwrap_value (ada_value_subscript
7321 (argvec
[0], nargs
, argvec
+ 1));
7323 case TYPE_CODE_ARRAY
:
7324 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7326 type
= ada_array_element_type (type
, nargs
);
7328 error ("element type of array unknown");
7330 return allocate_value (ada_aligned_type (type
));
7333 unwrap_value (ada_value_subscript
7334 (ada_coerce_to_simple_array (argvec
[0]),
7335 nargs
, argvec
+ 1));
7336 case TYPE_CODE_PTR
: /* Pointer to array */
7337 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7338 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7340 type
= ada_array_element_type (type
, nargs
);
7342 error ("element type of array unknown");
7344 return allocate_value (ada_aligned_type (type
));
7347 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7348 nargs
, argvec
+ 1));
7351 error ("Internal error in evaluate_subexp");
7356 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7357 struct value
*low_bound_val
=
7358 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7359 LONGEST low_bound
= pos_atr (low_bound_val
);
7361 = pos_atr (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7363 if (noside
== EVAL_SKIP
)
7366 /* If this is a reference to an aligner type, then remove all
7368 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7369 && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
))))
7370 TYPE_TARGET_TYPE (VALUE_TYPE (array
)) =
7371 ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)));
7373 if (ada_is_packed_array_type (VALUE_TYPE (array
)))
7374 error ("cannot slice a packed array");
7376 /* If this is a reference to an array or an array lvalue,
7377 convert to a pointer. */
7378 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7379 || (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_ARRAY
7380 && VALUE_LVAL (array
) == lval_memory
))
7381 array
= value_addr (array
);
7383 if (noside
== EVAL_AVOID_SIDE_EFFECTS
7384 && ada_is_array_descriptor_type (ada_check_typedef
7385 (VALUE_TYPE (array
))))
7386 return empty_array (ada_type_of_array (array
, 0), low_bound
);
7388 array
= ada_coerce_to_simple_array_ptr (array
);
7390 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
)
7392 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7393 return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
7397 struct type
*arr_type0
=
7398 to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
7400 return ada_value_slice_ptr (array
, arr_type0
,
7405 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7407 else if (high_bound
< low_bound
)
7408 return empty_array (VALUE_TYPE (array
), low_bound
);
7410 return ada_value_slice (array
, (int) low_bound
, (int) high_bound
);
7415 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7416 type
= exp
->elts
[pc
+ 1].type
;
7418 if (noside
== EVAL_SKIP
)
7421 switch (TYPE_CODE (type
))
7424 lim_warning ("Membership test incompletely implemented; "
7425 "always returns true");
7426 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
7428 case TYPE_CODE_RANGE
:
7429 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
7430 arg3
= value_from_longest (builtin_type_int
,
7431 TYPE_HIGH_BOUND (type
));
7433 value_from_longest (builtin_type_int
,
7434 (value_less (arg1
, arg3
)
7435 || value_equal (arg1
, arg3
))
7436 && (value_less (arg2
, arg1
)
7437 || value_equal (arg2
, arg1
)));
7440 case BINOP_IN_BOUNDS
:
7442 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7443 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7445 if (noside
== EVAL_SKIP
)
7448 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7449 return value_zero (builtin_type_int
, not_lval
);
7451 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7453 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg2
)))
7454 error ("invalid dimension number to '%s", "range");
7456 arg3
= ada_array_bound (arg2
, tem
, 1);
7457 arg2
= ada_array_bound (arg2
, tem
, 0);
7460 value_from_longest (builtin_type_int
,
7461 (value_less (arg1
, arg3
)
7462 || value_equal (arg1
, arg3
))
7463 && (value_less (arg2
, arg1
)
7464 || value_equal (arg2
, arg1
)));
7466 case TERNOP_IN_RANGE
:
7467 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7468 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7469 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7471 if (noside
== EVAL_SKIP
)
7475 value_from_longest (builtin_type_int
,
7476 (value_less (arg1
, arg3
)
7477 || value_equal (arg1
, arg3
))
7478 && (value_less (arg2
, arg1
)
7479 || value_equal (arg2
, arg1
)));
7485 struct type
*type_arg
;
7486 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
7488 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7490 type_arg
= exp
->elts
[pc
+ 2].type
;
7494 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7498 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
7499 error ("illegal operand to '%s", ada_attribute_name (op
));
7500 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
7503 if (noside
== EVAL_SKIP
)
7506 if (type_arg
== NULL
)
7508 arg1
= ada_coerce_ref (arg1
);
7510 if (ada_is_packed_array_type (VALUE_TYPE (arg1
)))
7511 arg1
= ada_coerce_to_simple_array (arg1
);
7513 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg1
)))
7514 error ("invalid dimension number to '%s",
7515 ada_attribute_name (op
));
7517 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7519 type
= ada_index_type (VALUE_TYPE (arg1
), tem
);
7522 ("attempt to take bound of something that is not an array");
7523 return allocate_value (type
);
7528 default: /* Should never happen. */
7529 error ("unexpected attribute encountered");
7531 return ada_array_bound (arg1
, tem
, 0);
7533 return ada_array_bound (arg1
, tem
, 1);
7535 return ada_array_length (arg1
, tem
);
7538 else if (discrete_type_p (type_arg
))
7540 struct type
*range_type
;
7541 char *name
= ada_type_name (type_arg
);
7543 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
7545 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
7546 if (range_type
== NULL
)
7547 range_type
= type_arg
;
7551 error ("unexpected attribute encountered");
7553 return discrete_type_low_bound (range_type
);
7555 return discrete_type_high_bound (range_type
);
7557 error ("the 'length attribute applies only to array types");
7560 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
7561 error ("unimplemented type attribute");
7566 if (ada_is_packed_array_type (type_arg
))
7567 type_arg
= decode_packed_array_type (type_arg
);
7569 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
7570 error ("invalid dimension number to '%s",
7571 ada_attribute_name (op
));
7573 type
= ada_index_type (type_arg
, tem
);
7576 ("attempt to take bound of something that is not an array");
7577 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7578 return allocate_value (type
);
7583 error ("unexpected attribute encountered");
7585 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7586 return value_from_longest (type
, low
);
7588 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
7589 return value_from_longest (type
, high
);
7591 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7592 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
7593 return value_from_longest (type
, high
- low
+ 1);
7599 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7600 if (noside
== EVAL_SKIP
)
7603 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7604 return value_zero (ada_tag_type (arg1
), not_lval
);
7606 return ada_value_tag (arg1
);
7610 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7611 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7612 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7613 if (noside
== EVAL_SKIP
)
7615 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7616 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7618 return value_binop (arg1
, arg2
,
7619 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
7621 case OP_ATR_MODULUS
:
7623 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
7624 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7626 if (noside
== EVAL_SKIP
)
7629 if (!ada_is_modular_type (type_arg
))
7630 error ("'modulus must be applied to modular type");
7632 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
7633 ada_modulus (type_arg
));
7638 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7639 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7640 if (noside
== EVAL_SKIP
)
7642 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7643 return value_zero (builtin_type_int
, not_lval
);
7645 return value_pos_atr (arg1
);
7648 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7649 if (noside
== EVAL_SKIP
)
7651 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7652 return value_zero (builtin_type_int
, not_lval
);
7654 return value_from_longest (builtin_type_int
,
7656 * TYPE_LENGTH (VALUE_TYPE (arg1
)));
7659 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7660 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7661 type
= exp
->elts
[pc
+ 2].type
;
7662 if (noside
== EVAL_SKIP
)
7664 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7665 return value_zero (type
, not_lval
);
7667 return value_val_atr (type
, arg1
);
7670 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7671 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7672 if (noside
== EVAL_SKIP
)
7674 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7675 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7677 return value_binop (arg1
, arg2
, op
);
7680 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7681 if (noside
== EVAL_SKIP
)
7687 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7688 if (noside
== EVAL_SKIP
)
7690 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7691 return value_neg (arg1
);
7696 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7697 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
7698 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7699 if (noside
== EVAL_SKIP
)
7701 type
= ada_check_typedef (VALUE_TYPE (arg1
));
7702 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7704 if (ada_is_array_descriptor_type (type
))
7705 /* GDB allows dereferencing GNAT array descriptors. */
7707 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7708 if (arrType
== NULL
)
7709 error ("Attempt to dereference null array pointer.");
7710 return value_at_lazy (arrType
, 0, NULL
);
7712 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7713 || TYPE_CODE (type
) == TYPE_CODE_REF
7714 /* In C you can dereference an array to get the 1st elt. */
7715 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7718 (to_static_fixed_type
7719 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7721 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7722 /* GDB allows dereferencing an int. */
7723 return value_zero (builtin_type_int
, lval_memory
);
7725 error ("Attempt to take contents of a non-pointer value.");
7727 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
7728 type
= ada_check_typedef (VALUE_TYPE (arg1
));
7730 if (ada_is_array_descriptor_type (type
))
7731 /* GDB allows dereferencing GNAT array descriptors. */
7732 return ada_coerce_to_simple_array (arg1
);
7734 return ada_value_ind (arg1
);
7736 case STRUCTOP_STRUCT
:
7737 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7738 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7739 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7740 if (noside
== EVAL_SKIP
)
7742 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7744 struct type
*type1
= VALUE_TYPE (arg1
);
7745 if (ada_is_tagged_type (type1
, 1))
7747 type
= ada_lookup_struct_elt_type (type1
,
7748 &exp
->elts
[pc
+ 2].string
,
7751 /* In this case, we assume that the field COULD exist
7752 in some extension of the type. Return an object of
7753 "type" void, which will match any formal
7754 (see ada_type_match). */
7755 return value_zero (builtin_type_void
, lval_memory
);
7759 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
7762 return value_zero (ada_aligned_type (type
), lval_memory
);
7766 ada_to_fixed_value (unwrap_value
7767 (ada_value_struct_elt
7768 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
7770 /* The value is not supposed to be used. This is here to make it
7771 easier to accommodate expressions that contain types. */
7773 if (noside
== EVAL_SKIP
)
7775 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7776 return allocate_value (builtin_type_void
);
7778 error ("Attempt to use a type name as an expression");
7782 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7788 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7789 type name that encodes the 'small and 'delta information.
7790 Otherwise, return NULL. */
7793 fixed_type_info (struct type
*type
)
7795 const char *name
= ada_type_name (type
);
7796 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7798 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7800 const char *tail
= strstr (name
, "___XF_");
7806 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7807 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7812 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7815 ada_is_fixed_point_type (struct type
*type
)
7817 return fixed_type_info (type
) != NULL
;
7820 /* Return non-zero iff TYPE represents a System.Address type. */
7823 ada_is_system_address_type (struct type
*type
)
7825 return (TYPE_NAME (type
)
7826 && strcmp (TYPE_NAME (type
), "system__address") == 0);
7829 /* Assuming that TYPE is the representation of an Ada fixed-point
7830 type, return its delta, or -1 if the type is malformed and the
7831 delta cannot be determined. */
7834 ada_delta (struct type
*type
)
7836 const char *encoding
= fixed_type_info (type
);
7839 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7842 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7845 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7846 factor ('SMALL value) associated with the type. */
7849 scaling_factor (struct type
*type
)
7851 const char *encoding
= fixed_type_info (type
);
7852 unsigned long num0
, den0
, num1
, den1
;
7855 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7860 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7862 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7866 /* Assuming that X is the representation of a value of fixed-point
7867 type TYPE, return its floating-point equivalent. */
7870 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7872 return (DOUBLEST
) x
*scaling_factor (type
);
7875 /* The representation of a fixed-point value of type TYPE
7876 corresponding to the value X. */
7879 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7881 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7885 /* VAX floating formats */
7887 /* Non-zero iff TYPE represents one of the special VAX floating-point
7891 ada_is_vax_floating_type (struct type
*type
)
7894 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7897 && (TYPE_CODE (type
) == TYPE_CODE_INT
7898 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7899 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
7902 /* The type of special VAX floating-point type this is, assuming
7903 ada_is_vax_floating_point. */
7906 ada_vax_float_type_suffix (struct type
*type
)
7908 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7911 /* A value representing the special debugging function that outputs
7912 VAX floating-point values of the type represented by TYPE. Assumes
7913 ada_is_vax_floating_type (TYPE). */
7916 ada_vax_float_print_function (struct type
*type
)
7918 switch (ada_vax_float_type_suffix (type
))
7921 return get_var_value ("DEBUG_STRING_F", 0);
7923 return get_var_value ("DEBUG_STRING_D", 0);
7925 return get_var_value ("DEBUG_STRING_G", 0);
7927 error ("invalid VAX floating-point type");
7934 /* Scan STR beginning at position K for a discriminant name, and
7935 return the value of that discriminant field of DVAL in *PX. If
7936 PNEW_K is not null, put the position of the character beyond the
7937 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7938 not alter *PX and *PNEW_K if unsuccessful. */
7941 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
7944 static char *bound_buffer
= NULL
;
7945 static size_t bound_buffer_len
= 0;
7948 struct value
*bound_val
;
7950 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7953 pend
= strstr (str
+ k
, "__");
7957 k
+= strlen (bound
);
7961 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7962 bound
= bound_buffer
;
7963 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7964 bound
[pend
- (str
+ k
)] = '\0';
7968 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7969 if (bound_val
== NULL
)
7972 *px
= value_as_long (bound_val
);
7978 /* Value of variable named NAME in the current environment. If
7979 no such variable found, then if ERR_MSG is null, returns 0, and
7980 otherwise causes an error with message ERR_MSG. */
7982 static struct value
*
7983 get_var_value (char *name
, char *err_msg
)
7985 struct ada_symbol_info
*syms
;
7988 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
7993 if (err_msg
== NULL
)
7996 error ("%s", err_msg
);
7999 return value_of_variable (syms
[0].sym
, syms
[0].block
);
8002 /* Value of integer variable named NAME in the current environment. If
8003 no such variable found, returns 0, and sets *FLAG to 0. If
8004 successful, sets *FLAG to 1. */
8007 get_int_var_value (char *name
, int *flag
)
8009 struct value
*var_val
= get_var_value (name
, 0);
8021 return value_as_long (var_val
);
8026 /* Return a range type whose base type is that of the range type named
8027 NAME in the current environment, and whose bounds are calculated
8028 from NAME according to the GNAT range encoding conventions.
8029 Extract discriminant values, if needed, from DVAL. If a new type
8030 must be created, allocate in OBJFILE's space. The bounds
8031 information, in general, is encoded in NAME, the base type given in
8032 the named range type. */
8034 static struct type
*
8035 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
8037 struct type
*raw_type
= ada_find_any_type (name
);
8038 struct type
*base_type
;
8041 if (raw_type
== NULL
)
8042 base_type
= builtin_type_int
;
8043 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
8044 base_type
= TYPE_TARGET_TYPE (raw_type
);
8046 base_type
= raw_type
;
8048 subtype_info
= strstr (name
, "___XD");
8049 if (subtype_info
== NULL
)
8053 static char *name_buf
= NULL
;
8054 static size_t name_len
= 0;
8055 int prefix_len
= subtype_info
- name
;
8061 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
8062 strncpy (name_buf
, name
, prefix_len
);
8063 name_buf
[prefix_len
] = '\0';
8066 bounds_str
= strchr (subtype_info
, '_');
8069 if (*subtype_info
== 'L')
8071 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
8072 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
8074 if (bounds_str
[n
] == '_')
8076 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
8083 strcpy (name_buf
+ prefix_len
, "___L");
8084 L
= get_int_var_value (name_buf
, &ok
);
8087 lim_warning ("Unknown lower bound, using 1.");
8092 if (*subtype_info
== 'U')
8094 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
8095 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
8101 strcpy (name_buf
+ prefix_len
, "___U");
8102 U
= get_int_var_value (name_buf
, &ok
);
8105 lim_warning ("Unknown upper bound, using %ld.", (long) L
);
8110 if (objfile
== NULL
)
8111 objfile
= TYPE_OBJFILE (base_type
);
8112 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
8113 TYPE_NAME (type
) = name
;
8118 /* True iff NAME is the name of a range type. */
8121 ada_is_range_type_name (const char *name
)
8123 return (name
!= NULL
&& strstr (name
, "___XD"));
8129 /* True iff TYPE is an Ada modular type. */
8132 ada_is_modular_type (struct type
*type
)
8134 struct type
*subranged_type
= base_type (type
);
8136 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
8137 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
8138 && TYPE_UNSIGNED (subranged_type
));
8141 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8144 ada_modulus (struct type
* type
)
8146 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
8150 /* Information about operators given special treatment in functions
8152 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
8154 #define ADA_OPERATORS \
8155 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
8156 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
8157 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
8158 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
8159 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
8160 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
8161 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
8162 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
8163 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
8164 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
8165 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
8166 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
8167 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
8168 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
8169 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
8170 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
8173 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
8175 switch (exp
->elts
[pc
- 1].opcode
)
8178 operator_length_standard (exp
, pc
, oplenp
, argsp
);
8181 #define OP_DEFN(op, len, args, binop) \
8182 case op: *oplenp = len; *argsp = args; break;
8189 ada_op_name (enum exp_opcode opcode
)
8194 return op_name_standard (opcode
);
8195 #define OP_DEFN(op, len, args, binop) case op: return #op;
8201 /* As for operator_length, but assumes PC is pointing at the first
8202 element of the operator, and gives meaningful results only for the
8203 Ada-specific operators. */
8206 ada_forward_operator_length (struct expression
*exp
, int pc
,
8207 int *oplenp
, int *argsp
)
8209 switch (exp
->elts
[pc
].opcode
)
8212 *oplenp
= *argsp
= 0;
8214 #define OP_DEFN(op, len, args, binop) \
8215 case op: *oplenp = len; *argsp = args; break;
8222 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
8224 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
8229 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
8233 /* Ada attributes ('Foo). */
8240 case OP_ATR_MODULUS
:
8249 fprintf_filtered (stream
, "Type @");
8250 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
8251 fprintf_filtered (stream
, " (");
8252 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
8253 fprintf_filtered (stream
, ")");
8255 case BINOP_IN_BOUNDS
:
8256 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
8258 case TERNOP_IN_RANGE
:
8262 return dump_subexp_body_standard (exp
, stream
, elt
);
8266 for (i
= 0; i
< nargs
; i
+= 1)
8267 elt
= dump_subexp (exp
, stream
, elt
);
8272 /* The Ada extension of print_subexp (q.v.). */
8275 ada_print_subexp (struct expression
*exp
, int *pos
,
8276 struct ui_file
*stream
, enum precedence prec
)
8280 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
8282 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8287 print_subexp_standard (exp
, pos
, stream
, prec
);
8292 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
8295 case BINOP_IN_BOUNDS
:
8297 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8298 fputs_filtered (" in ", stream
);
8299 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8300 fputs_filtered ("'range", stream
);
8301 if (exp
->elts
[pc
+ 1].longconst
> 1)
8302 fprintf_filtered (stream
, "(%ld)",
8303 (long) exp
->elts
[pc
+ 1].longconst
);
8306 case TERNOP_IN_RANGE
:
8308 if (prec
>= PREC_EQUAL
)
8309 fputs_filtered ("(", stream
);
8310 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8311 fputs_filtered (" in ", stream
);
8312 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8313 fputs_filtered (" .. ", stream
);
8314 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8315 if (prec
>= PREC_EQUAL
)
8316 fputs_filtered (")", stream
);
8325 case OP_ATR_MODULUS
:
8331 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8333 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
8334 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
8338 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8339 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
8343 for (tem
= 1; tem
< nargs
; tem
+= 1)
8345 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
8346 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
8348 fputs_filtered (")", stream
);
8354 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
8355 fputs_filtered ("'(", stream
);
8356 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
8357 fputs_filtered (")", stream
);
8362 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8363 fputs_filtered (" in ", stream
);
8364 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
8369 /* Table mapping opcodes into strings for printing operators
8370 and precedences of the operators. */
8372 static const struct op_print ada_op_print_tab
[] = {
8373 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
8374 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
8375 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
8376 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
8377 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
8378 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
8379 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
8380 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
8381 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
8382 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
8383 {">", BINOP_GTR
, PREC_ORDER
, 0},
8384 {"<", BINOP_LESS
, PREC_ORDER
, 0},
8385 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
8386 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
8387 {"+", BINOP_ADD
, PREC_ADD
, 0},
8388 {"-", BINOP_SUB
, PREC_ADD
, 0},
8389 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8390 {"*", BINOP_MUL
, PREC_MUL
, 0},
8391 {"/", BINOP_DIV
, PREC_MUL
, 0},
8392 {"rem", BINOP_REM
, PREC_MUL
, 0},
8393 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8394 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8395 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8396 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8397 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8398 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8399 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8400 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8401 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
8402 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
8403 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
8407 /* Fundamental Ada Types */
8409 /* Create a fundamental Ada type using default reasonable for the current
8412 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8413 define fundamental types such as "int" or "double". Others (stabs or
8414 DWARF version 2, etc) do define fundamental types. For the formats which
8415 don't provide fundamental types, gdb can create such types using this
8418 FIXME: Some compilers distinguish explicitly signed integral types
8419 (signed short, signed int, signed long) from "regular" integral types
8420 (short, int, long) in the debugging information. There is some dis-
8421 agreement as to how useful this feature is. In particular, gcc does
8422 not support this. Also, only some debugging formats allow the
8423 distinction to be passed on to a debugger. For now, we always just
8424 use "short", "int", or "long" as the type name, for both the implicit
8425 and explicitly signed types. This also makes life easier for the
8426 gdb test suite since we don't have to account for the differences
8427 in output depending upon what the compiler and debugging format
8428 support. We will probably have to re-examine the issue when gdb
8429 starts taking it's fundamental type information directly from the
8430 debugging information supplied by the compiler. fnf@cygnus.com */
8432 static struct type
*
8433 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8435 struct type
*type
= NULL
;
8440 /* FIXME: For now, if we are asked to produce a type not in this
8441 language, create the equivalent of a C integer type with the
8442 name "<?type?>". When all the dust settles from the type
8443 reconstruction work, this should probably become an error. */
8444 type
= init_type (TYPE_CODE_INT
,
8445 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8446 0, "<?type?>", objfile
);
8447 warning ("internal error: no Ada fundamental type %d", typeid);
8450 type
= init_type (TYPE_CODE_VOID
,
8451 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8452 0, "void", objfile
);
8455 type
= init_type (TYPE_CODE_INT
,
8456 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8457 0, "character", objfile
);
8459 case FT_SIGNED_CHAR
:
8460 type
= init_type (TYPE_CODE_INT
,
8461 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8462 0, "signed char", objfile
);
8464 case FT_UNSIGNED_CHAR
:
8465 type
= init_type (TYPE_CODE_INT
,
8466 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8467 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8470 type
= init_type (TYPE_CODE_INT
,
8471 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8472 0, "short_integer", objfile
);
8474 case FT_SIGNED_SHORT
:
8475 type
= init_type (TYPE_CODE_INT
,
8476 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8477 0, "short_integer", objfile
);
8479 case FT_UNSIGNED_SHORT
:
8480 type
= init_type (TYPE_CODE_INT
,
8481 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8482 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8485 type
= init_type (TYPE_CODE_INT
,
8486 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8487 0, "integer", objfile
);
8489 case FT_SIGNED_INTEGER
:
8490 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/
8492 0, "integer", objfile
); /* FIXME -fnf */
8494 case FT_UNSIGNED_INTEGER
:
8495 type
= init_type (TYPE_CODE_INT
,
8496 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8497 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8500 type
= init_type (TYPE_CODE_INT
,
8501 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8502 0, "long_integer", objfile
);
8504 case FT_SIGNED_LONG
:
8505 type
= init_type (TYPE_CODE_INT
,
8506 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8507 0, "long_integer", objfile
);
8509 case FT_UNSIGNED_LONG
:
8510 type
= init_type (TYPE_CODE_INT
,
8511 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8512 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8515 type
= init_type (TYPE_CODE_INT
,
8516 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8517 0, "long_long_integer", objfile
);
8519 case FT_SIGNED_LONG_LONG
:
8520 type
= init_type (TYPE_CODE_INT
,
8521 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8522 0, "long_long_integer", objfile
);
8524 case FT_UNSIGNED_LONG_LONG
:
8525 type
= init_type (TYPE_CODE_INT
,
8526 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8527 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8530 type
= init_type (TYPE_CODE_FLT
,
8531 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8532 0, "float", objfile
);
8534 case FT_DBL_PREC_FLOAT
:
8535 type
= init_type (TYPE_CODE_FLT
,
8536 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8537 0, "long_float", objfile
);
8539 case FT_EXT_PREC_FLOAT
:
8540 type
= init_type (TYPE_CODE_FLT
,
8541 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8542 0, "long_long_float", objfile
);
8548 enum ada_primitive_types
{
8549 ada_primitive_type_int
,
8550 ada_primitive_type_long
,
8551 ada_primitive_type_short
,
8552 ada_primitive_type_char
,
8553 ada_primitive_type_float
,
8554 ada_primitive_type_double
,
8555 ada_primitive_type_void
,
8556 ada_primitive_type_long_long
,
8557 ada_primitive_type_long_double
,
8558 ada_primitive_type_natural
,
8559 ada_primitive_type_positive
,
8560 ada_primitive_type_system_address
,
8561 nr_ada_primitive_types
8565 ada_language_arch_info (struct gdbarch
*current_gdbarch
,
8566 struct language_arch_info
*lai
)
8568 const struct builtin_type
*builtin
= builtin_type (current_gdbarch
);
8569 lai
->primitive_type_vector
8570 = GDBARCH_OBSTACK_CALLOC (current_gdbarch
, nr_ada_primitive_types
+ 1,
8572 lai
->primitive_type_vector
[ada_primitive_type_int
] =
8573 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8574 0, "integer", (struct objfile
*) NULL
);
8575 lai
->primitive_type_vector
[ada_primitive_type_long
] =
8576 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8577 0, "long_integer", (struct objfile
*) NULL
);
8578 lai
->primitive_type_vector
[ada_primitive_type_short
] =
8579 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8580 0, "short_integer", (struct objfile
*) NULL
);
8581 lai
->string_char_type
=
8582 lai
->primitive_type_vector
[ada_primitive_type_char
] =
8583 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8584 0, "character", (struct objfile
*) NULL
);
8585 lai
->primitive_type_vector
[ada_primitive_type_float
] =
8586 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8587 0, "float", (struct objfile
*) NULL
);
8588 lai
->primitive_type_vector
[ada_primitive_type_double
] =
8589 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8590 0, "long_float", (struct objfile
*) NULL
);
8591 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
8592 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8593 0, "long_long_integer", (struct objfile
*) NULL
);
8594 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
8595 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8596 0, "long_long_float", (struct objfile
*) NULL
);
8597 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
8598 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8599 0, "natural", (struct objfile
*) NULL
);
8600 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
8601 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8602 0, "positive", (struct objfile
*) NULL
);
8603 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
8605 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
8606 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8607 (struct objfile
*) NULL
));
8608 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
8609 = "system__address";
8612 /* Language vector */
8614 /* Not really used, but needed in the ada_language_defn. */
8617 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8619 ada_emit_char (c
, stream
, quoter
, 1);
8625 warnings_issued
= 0;
8626 return ada_parse ();
8629 static const struct exp_descriptor ada_exp_descriptor
= {
8631 ada_operator_length
,
8633 ada_dump_subexp_body
,
8637 const struct language_defn ada_language_defn
= {
8638 "ada", /* Language name */
8643 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8644 that's not quite what this means. */
8646 &ada_exp_descriptor
,
8650 ada_printchar
, /* Print a character constant */
8651 ada_printstr
, /* Function to print string constant */
8652 emit_char
, /* Function to print single char (not used) */
8653 ada_create_fundamental_type
, /* Create fundamental type in this language */
8654 ada_print_type
, /* Print a type using appropriate syntax */
8655 ada_val_print
, /* Print a value using appropriate syntax */
8656 ada_value_print
, /* Print a top-level value */
8657 NULL
, /* Language specific skip_trampoline */
8658 NULL
, /* value_of_this */
8659 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
8660 basic_lookup_transparent_type
, /* lookup_transparent_type */
8661 ada_la_decode
, /* Language specific symbol demangler */
8662 NULL
, /* Language specific class_name_from_physname */
8663 ada_op_print_tab
, /* expression operators for printing */
8664 0, /* c-style arrays */
8665 1, /* String lower bound */
8667 ada_get_gdb_completer_word_break_characters
,
8668 ada_language_arch_info
,
8673 _initialize_ada_language (void)
8675 add_language (&ada_language_defn
);
8677 varsize_limit
= 65536;
8679 obstack_init (&symbol_list_obstack
);
8681 decoded_names_store
= htab_create_alloc
8682 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
8683 NULL
, xcalloc
, xfree
);