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"
53 #include "exceptions.h"
55 #ifndef ADA_RETAIN_DOTS
56 #define ADA_RETAIN_DOTS 0
59 /* Define whether or not the C operator '/' truncates towards zero for
60 differently signed operands (truncation direction is undefined in C).
61 Copied from valarith.c. */
63 #ifndef TRUNCATION_TOWARDS_ZERO
64 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
68 static void extract_string (CORE_ADDR addr
, char *buf
);
70 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
72 static void modify_general_field (char *, LONGEST
, int, int);
74 static struct type
*desc_base_type (struct type
*);
76 static struct type
*desc_bounds_type (struct type
*);
78 static struct value
*desc_bounds (struct value
*);
80 static int fat_pntr_bounds_bitpos (struct type
*);
82 static int fat_pntr_bounds_bitsize (struct type
*);
84 static struct type
*desc_data_type (struct type
*);
86 static struct value
*desc_data (struct value
*);
88 static int fat_pntr_data_bitpos (struct type
*);
90 static int fat_pntr_data_bitsize (struct type
*);
92 static struct value
*desc_one_bound (struct value
*, int, int);
94 static int desc_bound_bitpos (struct type
*, int, int);
96 static int desc_bound_bitsize (struct type
*, int, int);
98 static struct type
*desc_index_type (struct type
*, int);
100 static int desc_arity (struct type
*);
102 static int ada_type_match (struct type
*, struct type
*, int);
104 static int ada_args_match (struct symbol
*, struct value
**, int);
106 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
108 static struct value
*convert_actual (struct value
*, struct type
*,
111 static struct value
*make_array_descriptor (struct type
*, struct value
*,
114 static void ada_add_block_symbols (struct obstack
*,
115 struct block
*, const char *,
116 domain_enum
, struct objfile
*,
117 struct symtab
*, int);
119 static int is_nonfunction (struct ada_symbol_info
*, int);
121 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
122 struct block
*, struct symtab
*);
124 static int num_defns_collected (struct obstack
*);
126 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
128 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
129 *, const char *, int,
132 static struct symtab
*symtab_for_sym (struct symbol
*);
134 static struct value
*resolve_subexp (struct expression
**, int *, int,
137 static void replace_operator_with_call (struct expression
**, int, int, int,
138 struct symbol
*, struct block
*);
140 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
142 static char *ada_op_name (enum exp_opcode
);
144 static const char *ada_decoded_op_name (enum exp_opcode
);
146 static int numeric_type_p (struct type
*);
148 static int integer_type_p (struct type
*);
150 static int scalar_type_p (struct type
*);
152 static int discrete_type_p (struct type
*);
154 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
157 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
160 static struct value
*evaluate_subexp_type (struct expression
*, int *);
162 static int is_dynamic_field (struct type
*, int);
164 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
165 CORE_ADDR
, struct value
*);
167 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
169 static struct type
*to_fixed_range_type (char *, struct value
*,
172 static struct type
*to_static_fixed_type (struct type
*);
174 static struct value
*unwrap_value (struct value
*);
176 static struct type
*packed_array_type (struct type
*, long *);
178 static struct type
*decode_packed_array_type (struct type
*);
180 static struct value
*decode_packed_array (struct value
*);
182 static struct value
*value_subscript_packed (struct value
*, int,
185 static struct value
*coerce_unspec_val_to_type (struct value
*,
188 static struct value
*get_var_value (char *, char *);
190 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
192 static int equiv_types (struct type
*, struct type
*);
194 static int is_name_suffix (const char *);
196 static int wild_match (const char *, int, const char *);
198 static struct value
*ada_coerce_ref (struct value
*);
200 static LONGEST
pos_atr (struct value
*);
202 static struct value
*value_pos_atr (struct value
*);
204 static struct value
*value_val_atr (struct type
*, struct value
*);
206 static struct symbol
*standard_lookup (const char *, const struct block
*,
209 static struct value
*ada_search_struct_field (char *, struct value
*, int,
212 static struct value
*ada_value_primitive_field (struct value
*, int, int,
215 static int find_struct_field (char *, struct type
*, int,
216 struct type
**, int *, int *, int *);
218 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
221 static struct value
*ada_to_fixed_value (struct value
*);
223 static int ada_resolve_function (struct ada_symbol_info
*, int,
224 struct value
**, int, const char *,
227 static struct value
*ada_coerce_to_simple_array (struct value
*);
229 static int ada_is_direct_array_type (struct type
*);
231 static void ada_language_arch_info (struct gdbarch
*,
232 struct language_arch_info
*);
234 static void check_size (const struct type
*);
238 /* Maximum-sized dynamic type. */
239 static unsigned int varsize_limit
;
241 /* FIXME: brobecker/2003-09-17: No longer a const because it is
242 returned by a function that does not return a const char *. */
243 static char *ada_completer_word_break_characters
=
245 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
247 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
250 /* The name of the symbol to use to get the name of the main subprogram. */
251 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
252 = "__gnat_ada_main_program_name";
254 /* The name of the runtime function called when an exception is raised. */
255 static const char raise_sym_name
[] = "__gnat_raise_nodefer_with_msg";
257 /* The name of the runtime function called when an unhandled exception
259 static const char raise_unhandled_sym_name
[] = "__gnat_unhandled_exception";
261 /* The name of the runtime function called when an assert failure is
263 static const char raise_assert_sym_name
[] =
264 "system__assertions__raise_assert_failure";
266 /* When GDB stops on an unhandled exception, GDB will go up the stack until
267 if finds a frame corresponding to this function, in order to extract the
268 name of the exception that has been raised from one of the parameters. */
269 static const char process_raise_exception_name
[] =
270 "ada__exceptions__process_raise_exception";
272 /* A string that reflects the longest exception expression rewrite,
273 aside from the exception name. */
274 static const char longest_exception_template
[] =
275 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
277 /* Limit on the number of warnings to raise per expression evaluation. */
278 static int warning_limit
= 2;
280 /* Number of warning messages issued; reset to 0 by cleanups after
281 expression evaluation. */
282 static int warnings_issued
= 0;
284 static const char *known_runtime_file_name_patterns
[] = {
285 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
288 static const char *known_auxiliary_function_name_patterns
[] = {
289 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
292 /* Space for allocating results of ada_lookup_symbol_list. */
293 static struct obstack symbol_list_obstack
;
299 ada_get_gdb_completer_word_break_characters (void)
301 return ada_completer_word_break_characters
;
304 /* Read the string located at ADDR from the inferior and store the
308 extract_string (CORE_ADDR addr
, char *buf
)
312 /* Loop, reading one byte at a time, until we reach the '\000'
313 end-of-string marker. */
316 target_read_memory (addr
+ char_index
* sizeof (char),
317 buf
+ char_index
* sizeof (char), sizeof (char));
320 while (buf
[char_index
- 1] != '\000');
323 /* Assuming VECT points to an array of *SIZE objects of size
324 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
325 updating *SIZE as necessary and returning the (new) array. */
328 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
330 if (*size
< min_size
)
333 if (*size
< min_size
)
335 vect
= xrealloc (vect
, *size
* element_size
);
340 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
341 suffix of FIELD_NAME beginning "___". */
344 field_name_match (const char *field_name
, const char *target
)
346 int len
= strlen (target
);
348 (strncmp (field_name
, target
, len
) == 0
349 && (field_name
[len
] == '\0'
350 || (strncmp (field_name
+ len
, "___", 3) == 0
351 && strcmp (field_name
+ strlen (field_name
) - 6,
356 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
357 FIELD_NAME, and return its index. This function also handles fields
358 whose name have ___ suffixes because the compiler sometimes alters
359 their name by adding such a suffix to represent fields with certain
360 constraints. If the field could not be found, return a negative
361 number if MAYBE_MISSING is set. Otherwise raise an error. */
364 ada_get_field_index (const struct type
*type
, const char *field_name
,
368 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
369 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
373 error (_("Unable to find field %s in struct %s. Aborting"),
374 field_name
, TYPE_NAME (type
));
379 /* The length of the prefix of NAME prior to any "___" suffix. */
382 ada_name_prefix_len (const char *name
)
388 const char *p
= strstr (name
, "___");
390 return strlen (name
);
396 /* Return non-zero if SUFFIX is a suffix of STR.
397 Return zero if STR is null. */
400 is_suffix (const char *str
, const char *suffix
)
406 len2
= strlen (suffix
);
407 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
410 /* Create a value of type TYPE whose contents come from VALADDR, if it
411 is non-null, and whose memory address (in the inferior) is
415 value_from_contents_and_address (struct type
*type
, char *valaddr
,
418 struct value
*v
= allocate_value (type
);
422 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
423 VALUE_ADDRESS (v
) = address
;
425 VALUE_LVAL (v
) = lval_memory
;
429 /* The contents of value VAL, treated as a value of type TYPE. The
430 result is an lval in memory if VAL is. */
432 static struct value
*
433 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
435 type
= ada_check_typedef (type
);
436 if (value_type (val
) == type
)
440 struct value
*result
;
442 /* Make sure that the object size is not unreasonable before
443 trying to allocate some memory for it. */
446 result
= allocate_value (type
);
447 VALUE_LVAL (result
) = VALUE_LVAL (val
);
448 result
->bitsize
= value_bitsize (val
);
449 result
->bitpos
= value_bitpos (val
);
450 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + value_offset (val
);
452 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
453 VALUE_LAZY (result
) = 1;
455 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
),
462 cond_offset_host (char *valaddr
, long offset
)
467 return valaddr
+ offset
;
471 cond_offset_target (CORE_ADDR address
, long offset
)
476 return address
+ offset
;
479 /* Issue a warning (as for the definition of warning in utils.c, but
480 with exactly one argument rather than ...), unless the limit on the
481 number of warnings has passed during the evaluation of the current
484 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
485 provided by "complaint". */
486 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
489 lim_warning (const char *format
, ...)
492 va_start (args
, format
);
494 warnings_issued
+= 1;
495 if (warnings_issued
<= warning_limit
)
496 vwarning (format
, args
);
501 /* Issue an error if the size of an object of type T is unreasonable,
502 i.e. if it would be a bad idea to allocate a value of this type in
506 check_size (const struct type
*type
)
508 if (TYPE_LENGTH (type
) > varsize_limit
)
509 error (_("object size is larger than varsize-limit"));
513 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
514 gdbtypes.h, but some of the necessary definitions in that file
515 seem to have gone missing. */
517 /* Maximum value of a SIZE-byte signed integer type. */
519 max_of_size (int size
)
521 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
522 return top_bit
| (top_bit
- 1);
525 /* Minimum value of a SIZE-byte signed integer type. */
527 min_of_size (int size
)
529 return -max_of_size (size
) - 1;
532 /* Maximum value of a SIZE-byte unsigned integer type. */
534 umax_of_size (int size
)
536 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
537 return top_bit
| (top_bit
- 1);
540 /* Maximum value of integral type T, as a signed quantity. */
542 max_of_type (struct type
*t
)
544 if (TYPE_UNSIGNED (t
))
545 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
547 return max_of_size (TYPE_LENGTH (t
));
550 /* Minimum value of integral type T, as a signed quantity. */
552 min_of_type (struct type
*t
)
554 if (TYPE_UNSIGNED (t
))
557 return min_of_size (TYPE_LENGTH (t
));
560 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
561 static struct value
*
562 discrete_type_high_bound (struct type
*type
)
564 switch (TYPE_CODE (type
))
566 case TYPE_CODE_RANGE
:
567 return value_from_longest (TYPE_TARGET_TYPE (type
),
568 TYPE_HIGH_BOUND (type
));
571 value_from_longest (type
,
572 TYPE_FIELD_BITPOS (type
,
573 TYPE_NFIELDS (type
) - 1));
575 return value_from_longest (type
, max_of_type (type
));
577 error (_("Unexpected type in discrete_type_high_bound."));
581 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
582 static struct value
*
583 discrete_type_low_bound (struct type
*type
)
585 switch (TYPE_CODE (type
))
587 case TYPE_CODE_RANGE
:
588 return value_from_longest (TYPE_TARGET_TYPE (type
),
589 TYPE_LOW_BOUND (type
));
591 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
593 return value_from_longest (type
, min_of_type (type
));
595 error (_("Unexpected type in discrete_type_low_bound."));
599 /* The identity on non-range types. For range types, the underlying
600 non-range scalar type. */
603 base_type (struct type
*type
)
605 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
607 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
609 type
= TYPE_TARGET_TYPE (type
);
615 /* Language Selection */
617 /* If the main program is in Ada, return language_ada, otherwise return LANG
618 (the main program is in Ada iif the adainit symbol is found).
620 MAIN_PST is not used. */
623 ada_update_initial_language (enum language lang
,
624 struct partial_symtab
*main_pst
)
626 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
627 (struct objfile
*) NULL
) != NULL
)
633 /* If the main procedure is written in Ada, then return its name.
634 The result is good until the next call. Return NULL if the main
635 procedure doesn't appear to be in Ada. */
640 struct minimal_symbol
*msym
;
641 CORE_ADDR main_program_name_addr
;
642 static char main_program_name
[1024];
644 /* For Ada, the name of the main procedure is stored in a specific
645 string constant, generated by the binder. Look for that symbol,
646 extract its address, and then read that string. If we didn't find
647 that string, then most probably the main procedure is not written
649 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
653 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
654 if (main_program_name_addr
== 0)
655 error (_("Invalid address for Ada main program name."));
657 extract_string (main_program_name_addr
, main_program_name
);
658 return main_program_name
;
661 /* The main procedure doesn't seem to be in Ada. */
667 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
670 const struct ada_opname_map ada_opname_table
[] = {
671 {"Oadd", "\"+\"", BINOP_ADD
},
672 {"Osubtract", "\"-\"", BINOP_SUB
},
673 {"Omultiply", "\"*\"", BINOP_MUL
},
674 {"Odivide", "\"/\"", BINOP_DIV
},
675 {"Omod", "\"mod\"", BINOP_MOD
},
676 {"Orem", "\"rem\"", BINOP_REM
},
677 {"Oexpon", "\"**\"", BINOP_EXP
},
678 {"Olt", "\"<\"", BINOP_LESS
},
679 {"Ole", "\"<=\"", BINOP_LEQ
},
680 {"Ogt", "\">\"", BINOP_GTR
},
681 {"Oge", "\">=\"", BINOP_GEQ
},
682 {"Oeq", "\"=\"", BINOP_EQUAL
},
683 {"One", "\"/=\"", BINOP_NOTEQUAL
},
684 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
685 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
686 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
687 {"Oconcat", "\"&\"", BINOP_CONCAT
},
688 {"Oabs", "\"abs\"", UNOP_ABS
},
689 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
690 {"Oadd", "\"+\"", UNOP_PLUS
},
691 {"Osubtract", "\"-\"", UNOP_NEG
},
695 /* Return non-zero if STR should be suppressed in info listings. */
698 is_suppressed_name (const char *str
)
700 if (strncmp (str
, "_ada_", 5) == 0)
702 if (str
[0] == '_' || str
[0] == '\000')
707 const char *suffix
= strstr (str
, "___");
708 if (suffix
!= NULL
&& suffix
[3] != 'X')
711 suffix
= str
+ strlen (str
);
712 for (p
= suffix
- 1; p
!= str
; p
-= 1)
716 if (p
[0] == 'X' && p
[-1] != '_')
720 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
721 if (strncmp (ada_opname_table
[i
].encoded
, p
,
722 strlen (ada_opname_table
[i
].encoded
)) == 0)
731 /* The "encoded" form of DECODED, according to GNAT conventions.
732 The result is valid until the next call to ada_encode. */
735 ada_encode (const char *decoded
)
737 static char *encoding_buffer
= NULL
;
738 static size_t encoding_buffer_size
= 0;
745 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
746 2 * strlen (decoded
) + 10);
749 for (p
= decoded
; *p
!= '\0'; p
+= 1)
751 if (!ADA_RETAIN_DOTS
&& *p
== '.')
753 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
758 const struct ada_opname_map
*mapping
;
760 for (mapping
= ada_opname_table
;
761 mapping
->encoded
!= NULL
762 && strncmp (mapping
->decoded
, p
,
763 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
765 if (mapping
->encoded
== NULL
)
766 error (_("invalid Ada operator name: %s"), p
);
767 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
768 k
+= strlen (mapping
->encoded
);
773 encoding_buffer
[k
] = *p
;
778 encoding_buffer
[k
] = '\0';
779 return encoding_buffer
;
782 /* Return NAME folded to lower case, or, if surrounded by single
783 quotes, unfolded, but with the quotes stripped away. Result good
787 ada_fold_name (const char *name
)
789 static char *fold_buffer
= NULL
;
790 static size_t fold_buffer_size
= 0;
792 int len
= strlen (name
);
793 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
797 strncpy (fold_buffer
, name
+ 1, len
- 2);
798 fold_buffer
[len
- 2] = '\000';
803 for (i
= 0; i
<= len
; i
+= 1)
804 fold_buffer
[i
] = tolower (name
[i
]);
811 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
812 These are suffixes introduced by GNAT5 to nested subprogram
813 names, and do not serve any purpose for the debugger.
814 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
815 2. Convert other instances of embedded "__" to `.'.
816 3. Discard leading _ada_.
817 4. Convert operator names to the appropriate quoted symbols.
818 5. Remove everything after first ___ if it is followed by
820 6. Replace TK__ with __, and a trailing B or TKB with nothing.
821 7. Put symbols that should be suppressed in <...> brackets.
822 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
824 The resulting string is valid until the next call of ada_decode.
825 If the string is unchanged by demangling, the original string pointer
829 ada_decode (const char *encoded
)
836 static char *decoding_buffer
= NULL
;
837 static size_t decoding_buffer_size
= 0;
839 if (strncmp (encoded
, "_ada_", 5) == 0)
842 if (encoded
[0] == '_' || encoded
[0] == '<')
845 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
846 len0
= strlen (encoded
);
847 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
850 while (i
> 0 && isdigit (encoded
[i
]))
852 if (i
>= 0 && encoded
[i
] == '.')
854 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
858 /* Remove the ___X.* suffix if present. Do not forget to verify that
859 the suffix is located before the current "end" of ENCODED. We want
860 to avoid re-matching parts of ENCODED that have previously been
861 marked as discarded (by decrementing LEN0). */
862 p
= strstr (encoded
, "___");
863 if (p
!= NULL
&& p
- encoded
< len0
- 3)
871 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
874 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
877 /* Make decoded big enough for possible expansion by operator name. */
878 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
879 decoded
= decoding_buffer
;
881 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
884 while ((i
>= 0 && isdigit (encoded
[i
]))
885 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
887 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
889 else if (encoded
[i
] == '$')
893 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
894 decoded
[j
] = encoded
[i
];
899 if (at_start_name
&& encoded
[i
] == 'O')
902 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
904 int op_len
= strlen (ada_opname_table
[k
].encoded
);
905 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
907 && !isalnum (encoded
[i
+ op_len
]))
909 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
912 j
+= strlen (ada_opname_table
[k
].decoded
);
916 if (ada_opname_table
[k
].encoded
!= NULL
)
921 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
923 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
927 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
931 else if (!ADA_RETAIN_DOTS
932 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
941 decoded
[j
] = encoded
[i
];
948 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
949 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
952 if (strcmp (decoded
, encoded
) == 0)
958 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
959 decoded
= decoding_buffer
;
960 if (encoded
[0] == '<')
961 strcpy (decoded
, encoded
);
963 sprintf (decoded
, "<%s>", encoded
);
968 /* Table for keeping permanent unique copies of decoded names. Once
969 allocated, names in this table are never released. While this is a
970 storage leak, it should not be significant unless there are massive
971 changes in the set of decoded names in successive versions of a
972 symbol table loaded during a single session. */
973 static struct htab
*decoded_names_store
;
975 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
976 in the language-specific part of GSYMBOL, if it has not been
977 previously computed. Tries to save the decoded name in the same
978 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
979 in any case, the decoded symbol has a lifetime at least that of
981 The GSYMBOL parameter is "mutable" in the C++ sense: logically
982 const, but nevertheless modified to a semantically equivalent form
983 when a decoded name is cached in it.
987 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
990 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
991 if (*resultp
== NULL
)
993 const char *decoded
= ada_decode (gsymbol
->name
);
994 if (gsymbol
->bfd_section
!= NULL
)
996 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
999 struct objfile
*objf
;
1002 if (obfd
== objf
->obfd
)
1004 *resultp
= obsavestring (decoded
, strlen (decoded
),
1005 &objf
->objfile_obstack
);
1011 /* Sometimes, we can't find a corresponding objfile, in which
1012 case, we put the result on the heap. Since we only decode
1013 when needed, we hope this usually does not cause a
1014 significant memory leak (FIXME). */
1015 if (*resultp
== NULL
)
1017 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1020 *slot
= xstrdup (decoded
);
1029 ada_la_decode (const char *encoded
, int options
)
1031 return xstrdup (ada_decode (encoded
));
1034 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1035 suffixes that encode debugging information or leading _ada_ on
1036 SYM_NAME (see is_name_suffix commentary for the debugging
1037 information that is ignored). If WILD, then NAME need only match a
1038 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1039 either argument is NULL. */
1042 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1044 if (sym_name
== NULL
|| name
== NULL
)
1047 return wild_match (name
, strlen (name
), sym_name
);
1050 int len_name
= strlen (name
);
1051 return (strncmp (sym_name
, name
, len_name
) == 0
1052 && is_name_suffix (sym_name
+ len_name
))
1053 || (strncmp (sym_name
, "_ada_", 5) == 0
1054 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1055 && is_name_suffix (sym_name
+ len_name
+ 5));
1059 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1060 suppressed in info listings. */
1063 ada_suppress_symbol_printing (struct symbol
*sym
)
1065 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1068 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1074 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1076 static char *bound_name
[] = {
1077 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1078 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1081 /* Maximum number of array dimensions we are prepared to handle. */
1083 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1085 /* Like modify_field, but allows bitpos > wordlength. */
1088 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1090 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1094 /* The desc_* routines return primitive portions of array descriptors
1097 /* The descriptor or array type, if any, indicated by TYPE; removes
1098 level of indirection, if needed. */
1100 static struct type
*
1101 desc_base_type (struct type
*type
)
1105 type
= ada_check_typedef (type
);
1107 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1108 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1109 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1114 /* True iff TYPE indicates a "thin" array pointer type. */
1117 is_thin_pntr (struct type
*type
)
1120 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1121 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1124 /* The descriptor type for thin pointer type TYPE. */
1126 static struct type
*
1127 thin_descriptor_type (struct type
*type
)
1129 struct type
*base_type
= desc_base_type (type
);
1130 if (base_type
== NULL
)
1132 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1136 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1137 if (alt_type
== NULL
)
1144 /* A pointer to the array data for thin-pointer value VAL. */
1146 static struct value
*
1147 thin_data_pntr (struct value
*val
)
1149 struct type
*type
= value_type (val
);
1150 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1151 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1154 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1155 VALUE_ADDRESS (val
) + value_offset (val
));
1158 /* True iff TYPE indicates a "thick" array pointer type. */
1161 is_thick_pntr (struct type
*type
)
1163 type
= desc_base_type (type
);
1164 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1165 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1168 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1169 pointer to one, the type of its bounds data; otherwise, NULL. */
1171 static struct type
*
1172 desc_bounds_type (struct type
*type
)
1176 type
= desc_base_type (type
);
1180 else if (is_thin_pntr (type
))
1182 type
= thin_descriptor_type (type
);
1185 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1187 return ada_check_typedef (r
);
1189 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1191 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1193 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1198 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1199 one, a pointer to its bounds data. Otherwise NULL. */
1201 static struct value
*
1202 desc_bounds (struct value
*arr
)
1204 struct type
*type
= ada_check_typedef (value_type (arr
));
1205 if (is_thin_pntr (type
))
1207 struct type
*bounds_type
=
1208 desc_bounds_type (thin_descriptor_type (type
));
1211 if (desc_bounds_type
== NULL
)
1212 error (_("Bad GNAT array descriptor"));
1214 /* NOTE: The following calculation is not really kosher, but
1215 since desc_type is an XVE-encoded type (and shouldn't be),
1216 the correct calculation is a real pain. FIXME (and fix GCC). */
1217 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1218 addr
= value_as_long (arr
);
1220 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1223 value_from_longest (lookup_pointer_type (bounds_type
),
1224 addr
- TYPE_LENGTH (bounds_type
));
1227 else if (is_thick_pntr (type
))
1228 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1229 _("Bad GNAT array descriptor"));
1234 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1235 position of the field containing the address of the bounds data. */
1238 fat_pntr_bounds_bitpos (struct type
*type
)
1240 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1243 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1244 size of the field containing the address of the bounds data. */
1247 fat_pntr_bounds_bitsize (struct type
*type
)
1249 type
= desc_base_type (type
);
1251 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1252 return TYPE_FIELD_BITSIZE (type
, 1);
1254 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1257 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1258 pointer to one, the type of its array data (a
1259 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1260 ada_type_of_array to get an array type with bounds data. */
1262 static struct type
*
1263 desc_data_type (struct type
*type
)
1265 type
= desc_base_type (type
);
1267 /* NOTE: The following is bogus; see comment in desc_bounds. */
1268 if (is_thin_pntr (type
))
1269 return lookup_pointer_type
1270 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1271 else if (is_thick_pntr (type
))
1272 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1277 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1280 static struct value
*
1281 desc_data (struct value
*arr
)
1283 struct type
*type
= value_type (arr
);
1284 if (is_thin_pntr (type
))
1285 return thin_data_pntr (arr
);
1286 else if (is_thick_pntr (type
))
1287 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1288 _("Bad GNAT array descriptor"));
1294 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1295 position of the field containing the address of the data. */
1298 fat_pntr_data_bitpos (struct type
*type
)
1300 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1303 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1304 size of the field containing the address of the data. */
1307 fat_pntr_data_bitsize (struct type
*type
)
1309 type
= desc_base_type (type
);
1311 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1312 return TYPE_FIELD_BITSIZE (type
, 0);
1314 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1317 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1318 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1319 bound, if WHICH is 1. The first bound is I=1. */
1321 static struct value
*
1322 desc_one_bound (struct value
*bounds
, int i
, int which
)
1324 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1325 _("Bad GNAT array descriptor bounds"));
1328 /* If BOUNDS is an array-bounds structure type, return the bit position
1329 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1330 bound, if WHICH is 1. The first bound is I=1. */
1333 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1335 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1338 /* If BOUNDS is an array-bounds structure type, return the bit field size
1339 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1340 bound, if WHICH is 1. The first bound is I=1. */
1343 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1345 type
= desc_base_type (type
);
1347 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1348 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1350 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1353 /* If TYPE is the type of an array-bounds structure, the type of its
1354 Ith bound (numbering from 1). Otherwise, NULL. */
1356 static struct type
*
1357 desc_index_type (struct type
*type
, int i
)
1359 type
= desc_base_type (type
);
1361 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1362 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1367 /* The number of index positions in the array-bounds type TYPE.
1368 Return 0 if TYPE is NULL. */
1371 desc_arity (struct type
*type
)
1373 type
= desc_base_type (type
);
1376 return TYPE_NFIELDS (type
) / 2;
1380 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1381 an array descriptor type (representing an unconstrained array
1385 ada_is_direct_array_type (struct type
*type
)
1389 type
= ada_check_typedef (type
);
1390 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1391 || ada_is_array_descriptor_type (type
));
1394 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1397 ada_is_simple_array_type (struct type
*type
)
1401 type
= ada_check_typedef (type
);
1402 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1403 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1404 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1407 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1410 ada_is_array_descriptor_type (struct type
*type
)
1412 struct type
*data_type
= desc_data_type (type
);
1416 type
= ada_check_typedef (type
);
1419 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1420 && TYPE_TARGET_TYPE (data_type
) != NULL
1421 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1422 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1423 && desc_arity (desc_bounds_type (type
)) > 0;
1426 /* Non-zero iff type is a partially mal-formed GNAT array
1427 descriptor. FIXME: This is to compensate for some problems with
1428 debugging output from GNAT. Re-examine periodically to see if it
1432 ada_is_bogus_array_descriptor (struct type
*type
)
1436 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1437 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1438 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1439 && !ada_is_array_descriptor_type (type
);
1443 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1444 (fat pointer) returns the type of the array data described---specifically,
1445 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1446 in from the descriptor; otherwise, they are left unspecified. If
1447 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1448 returns NULL. The result is simply the type of ARR if ARR is not
1451 ada_type_of_array (struct value
*arr
, int bounds
)
1453 if (ada_is_packed_array_type (value_type (arr
)))
1454 return decode_packed_array_type (value_type (arr
));
1456 if (!ada_is_array_descriptor_type (value_type (arr
)))
1457 return value_type (arr
);
1461 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1464 struct type
*elt_type
;
1466 struct value
*descriptor
;
1467 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1469 elt_type
= ada_array_element_type (value_type (arr
), -1);
1470 arity
= ada_array_arity (value_type (arr
));
1472 if (elt_type
== NULL
|| arity
== 0)
1473 return ada_check_typedef (value_type (arr
));
1475 descriptor
= desc_bounds (arr
);
1476 if (value_as_long (descriptor
) == 0)
1480 struct type
*range_type
= alloc_type (objf
);
1481 struct type
*array_type
= alloc_type (objf
);
1482 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1483 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1486 create_range_type (range_type
, value_type (low
),
1487 (int) value_as_long (low
),
1488 (int) value_as_long (high
));
1489 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1492 return lookup_pointer_type (elt_type
);
1496 /* If ARR does not represent an array, returns ARR unchanged.
1497 Otherwise, returns either a standard GDB array with bounds set
1498 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1499 GDB array. Returns NULL if ARR is a null fat pointer. */
1502 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1504 if (ada_is_array_descriptor_type (value_type (arr
)))
1506 struct type
*arrType
= ada_type_of_array (arr
, 1);
1507 if (arrType
== NULL
)
1509 return value_cast (arrType
, value_copy (desc_data (arr
)));
1511 else if (ada_is_packed_array_type (value_type (arr
)))
1512 return decode_packed_array (arr
);
1517 /* If ARR does not represent an array, returns ARR unchanged.
1518 Otherwise, returns a standard GDB array describing ARR (which may
1519 be ARR itself if it already is in the proper form). */
1521 static struct value
*
1522 ada_coerce_to_simple_array (struct value
*arr
)
1524 if (ada_is_array_descriptor_type (value_type (arr
)))
1526 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1528 error (_("Bounds unavailable for null array pointer."));
1529 return value_ind (arrVal
);
1531 else if (ada_is_packed_array_type (value_type (arr
)))
1532 return decode_packed_array (arr
);
1537 /* If TYPE represents a GNAT array type, return it translated to an
1538 ordinary GDB array type (possibly with BITSIZE fields indicating
1539 packing). For other types, is the identity. */
1542 ada_coerce_to_simple_array_type (struct type
*type
)
1544 struct value
*mark
= value_mark ();
1545 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1546 struct type
*result
;
1548 result
= ada_type_of_array (dummy
, 0);
1549 value_free_to_mark (mark
);
1553 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1556 ada_is_packed_array_type (struct type
*type
)
1560 type
= desc_base_type (type
);
1561 type
= ada_check_typedef (type
);
1563 ada_type_name (type
) != NULL
1564 && strstr (ada_type_name (type
), "___XP") != NULL
;
1567 /* Given that TYPE is a standard GDB array type with all bounds filled
1568 in, and that the element size of its ultimate scalar constituents
1569 (that is, either its elements, or, if it is an array of arrays, its
1570 elements' elements, etc.) is *ELT_BITS, return an identical type,
1571 but with the bit sizes of its elements (and those of any
1572 constituent arrays) recorded in the BITSIZE components of its
1573 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1576 static struct type
*
1577 packed_array_type (struct type
*type
, long *elt_bits
)
1579 struct type
*new_elt_type
;
1580 struct type
*new_type
;
1581 LONGEST low_bound
, high_bound
;
1583 type
= ada_check_typedef (type
);
1584 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1587 new_type
= alloc_type (TYPE_OBJFILE (type
));
1588 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1590 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1591 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1592 TYPE_NAME (new_type
) = ada_type_name (type
);
1594 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1595 &low_bound
, &high_bound
) < 0)
1596 low_bound
= high_bound
= 0;
1597 if (high_bound
< low_bound
)
1598 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1601 *elt_bits
*= (high_bound
- low_bound
+ 1);
1602 TYPE_LENGTH (new_type
) =
1603 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1606 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1610 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1612 static struct type
*
1613 decode_packed_array_type (struct type
*type
)
1616 struct block
**blocks
;
1617 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
1618 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1619 char *tail
= strstr (raw_name
, "___XP");
1620 struct type
*shadow_type
;
1624 type
= desc_base_type (type
);
1626 memcpy (name
, raw_name
, tail
- raw_name
);
1627 name
[tail
- raw_name
] = '\000';
1629 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1630 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1632 lim_warning (_("could not find bounds information on packed array"));
1635 shadow_type
= SYMBOL_TYPE (sym
);
1637 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1639 lim_warning (_("could not understand bounds information on packed array"));
1643 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1646 (_("could not understand bit size information on packed array"));
1650 return packed_array_type (shadow_type
, &bits
);
1653 /* Given that ARR is a struct value *indicating a GNAT packed array,
1654 returns a simple array that denotes that array. Its type is a
1655 standard GDB array type except that the BITSIZEs of the array
1656 target types are set to the number of bits in each element, and the
1657 type length is set appropriately. */
1659 static struct value
*
1660 decode_packed_array (struct value
*arr
)
1664 arr
= ada_coerce_ref (arr
);
1665 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1666 arr
= ada_value_ind (arr
);
1668 type
= decode_packed_array_type (value_type (arr
));
1671 error (_("can't unpack array"));
1675 if (BITS_BIG_ENDIAN
&& ada_is_modular_type (value_type (arr
)))
1677 /* This is a (right-justified) modular type representing a packed
1678 array with no wrapper. In order to interpret the value through
1679 the (left-justified) packed array type we just built, we must
1680 first left-justify it. */
1681 int bit_size
, bit_pos
;
1684 mod
= ada_modulus (value_type (arr
)) - 1;
1691 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1692 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1693 bit_pos
/ HOST_CHAR_BIT
,
1694 bit_pos
% HOST_CHAR_BIT
,
1699 return coerce_unspec_val_to_type (arr
, type
);
1703 /* The value of the element of packed array ARR at the ARITY indices
1704 given in IND. ARR must be a simple array. */
1706 static struct value
*
1707 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1710 int bits
, elt_off
, bit_off
;
1711 long elt_total_bit_offset
;
1712 struct type
*elt_type
;
1716 elt_total_bit_offset
= 0;
1717 elt_type
= ada_check_typedef (value_type (arr
));
1718 for (i
= 0; i
< arity
; i
+= 1)
1720 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1721 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1723 (_("attempt to do packed indexing of something other than a packed array"));
1726 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1727 LONGEST lowerbound
, upperbound
;
1730 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1732 lim_warning (_("don't know bounds of array"));
1733 lowerbound
= upperbound
= 0;
1736 idx
= value_as_long (value_pos_atr (ind
[i
]));
1737 if (idx
< lowerbound
|| idx
> upperbound
)
1738 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1739 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1740 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1741 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1744 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1745 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1747 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1749 if (VALUE_LVAL (arr
) == lval_internalvar
)
1750 VALUE_LVAL (v
) = lval_internalvar_component
;
1752 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1756 /* Non-zero iff TYPE includes negative integer values. */
1759 has_negatives (struct type
*type
)
1761 switch (TYPE_CODE (type
))
1766 return !TYPE_UNSIGNED (type
);
1767 case TYPE_CODE_RANGE
:
1768 return TYPE_LOW_BOUND (type
) < 0;
1773 /* Create a new value of type TYPE from the contents of OBJ starting
1774 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1775 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1776 assigning through the result will set the field fetched from.
1777 VALADDR is ignored unless OBJ is NULL, in which case,
1778 VALADDR+OFFSET must address the start of storage containing the
1779 packed value. The value returned in this case is never an lval.
1780 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1783 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1784 int bit_offset
, int bit_size
,
1788 int src
, /* Index into the source area */
1789 targ
, /* Index into the target area */
1790 srcBitsLeft
, /* Number of source bits left to move */
1791 nsrc
, ntarg
, /* Number of source and target bytes */
1792 unusedLS
, /* Number of bits in next significant
1793 byte of source that are unused */
1794 accumSize
; /* Number of meaningful bits in accum */
1795 unsigned char *bytes
; /* First byte containing data to unpack */
1796 unsigned char *unpacked
;
1797 unsigned long accum
; /* Staging area for bits being transferred */
1799 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1800 /* Transmit bytes from least to most significant; delta is the direction
1801 the indices move. */
1802 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1804 type
= ada_check_typedef (type
);
1808 v
= allocate_value (type
);
1809 bytes
= (unsigned char *) (valaddr
+ offset
);
1811 else if (VALUE_LAZY (obj
))
1814 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
1815 bytes
= (unsigned char *) alloca (len
);
1816 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1820 v
= allocate_value (type
);
1821 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1826 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1827 if (VALUE_LVAL (obj
) == lval_internalvar
)
1828 VALUE_LVAL (v
) = lval_internalvar_component
;
1829 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
;
1830 v
->bitpos
= bit_offset
+ value_bitpos (obj
);
1831 v
->bitsize
= bit_size
;
1832 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
1834 VALUE_ADDRESS (v
) += 1;
1835 v
->bitpos
-= HOST_CHAR_BIT
;
1839 v
->bitsize
= bit_size
;
1840 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1842 srcBitsLeft
= bit_size
;
1844 ntarg
= TYPE_LENGTH (type
);
1848 memset (unpacked
, 0, TYPE_LENGTH (type
));
1851 else if (BITS_BIG_ENDIAN
)
1854 if (has_negatives (type
)
1855 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1859 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1862 switch (TYPE_CODE (type
))
1864 case TYPE_CODE_ARRAY
:
1865 case TYPE_CODE_UNION
:
1866 case TYPE_CODE_STRUCT
:
1867 /* Non-scalar values must be aligned at a byte boundary... */
1869 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1870 /* ... And are placed at the beginning (most-significant) bytes
1876 targ
= TYPE_LENGTH (type
) - 1;
1882 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1885 unusedLS
= bit_offset
;
1888 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1895 /* Mask for removing bits of the next source byte that are not
1896 part of the value. */
1897 unsigned int unusedMSMask
=
1898 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1900 /* Sign-extend bits for this byte. */
1901 unsigned int signMask
= sign
& ~unusedMSMask
;
1903 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1904 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1905 if (accumSize
>= HOST_CHAR_BIT
)
1907 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1908 accumSize
-= HOST_CHAR_BIT
;
1909 accum
>>= HOST_CHAR_BIT
;
1913 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1920 accum
|= sign
<< accumSize
;
1921 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1922 accumSize
-= HOST_CHAR_BIT
;
1923 accum
>>= HOST_CHAR_BIT
;
1931 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1932 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1935 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
1937 unsigned int accum
, mask
;
1938 int accum_bits
, chunk_size
;
1940 target
+= targ_offset
/ HOST_CHAR_BIT
;
1941 targ_offset
%= HOST_CHAR_BIT
;
1942 source
+= src_offset
/ HOST_CHAR_BIT
;
1943 src_offset
%= HOST_CHAR_BIT
;
1944 if (BITS_BIG_ENDIAN
)
1946 accum
= (unsigned char) *source
;
1948 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1953 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1954 accum_bits
+= HOST_CHAR_BIT
;
1956 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1959 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1960 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1963 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1965 accum_bits
-= chunk_size
;
1972 accum
= (unsigned char) *source
>> src_offset
;
1974 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1978 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1979 accum_bits
+= HOST_CHAR_BIT
;
1981 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1984 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1985 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1987 accum_bits
-= chunk_size
;
1988 accum
>>= chunk_size
;
1996 /* Store the contents of FROMVAL into the location of TOVAL.
1997 Return a new value with the location of TOVAL and contents of
1998 FROMVAL. Handles assignment into packed fields that have
1999 floating-point or non-scalar types. */
2001 static struct value
*
2002 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2004 struct type
*type
= value_type (toval
);
2005 int bits
= value_bitsize (toval
);
2007 if (!toval
->modifiable
)
2008 error (_("Left operand of assignment is not a modifiable lvalue."));
2010 toval
= coerce_ref (toval
);
2012 if (VALUE_LVAL (toval
) == lval_memory
2014 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2015 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2017 int len
= (value_bitpos (toval
)
2018 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2019 char *buffer
= (char *) alloca (len
);
2022 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2023 fromval
= value_cast (type
, fromval
);
2025 read_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
, len
);
2026 if (BITS_BIG_ENDIAN
)
2027 move_bits (buffer
, value_bitpos (toval
),
2028 VALUE_CONTENTS (fromval
),
2029 TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
-
2032 move_bits (buffer
, value_bitpos (toval
), VALUE_CONTENTS (fromval
),
2034 write_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
,
2037 val
= value_copy (toval
);
2038 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
2039 TYPE_LENGTH (type
));
2045 return value_assign (toval
, fromval
);
2049 /* The value of the element of array ARR at the ARITY indices given in IND.
2050 ARR may be either a simple array, GNAT array descriptor, or pointer
2054 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2058 struct type
*elt_type
;
2060 elt
= ada_coerce_to_simple_array (arr
);
2062 elt_type
= ada_check_typedef (value_type (elt
));
2063 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2064 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2065 return value_subscript_packed (elt
, arity
, ind
);
2067 for (k
= 0; k
< arity
; k
+= 1)
2069 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2070 error (_("too many subscripts (%d expected)"), k
);
2071 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2076 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2077 value of the element of *ARR at the ARITY indices given in
2078 IND. Does not read the entire array into memory. */
2081 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2086 for (k
= 0; k
< arity
; k
+= 1)
2091 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2092 error (_("too many subscripts (%d expected)"), k
);
2093 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2095 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2096 idx
= value_pos_atr (ind
[k
]);
2098 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2099 arr
= value_add (arr
, idx
);
2100 type
= TYPE_TARGET_TYPE (type
);
2103 return value_ind (arr
);
2106 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2107 actual type of ARRAY_PTR is ignored), returns a reference to
2108 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2109 bound of this array is LOW, as per Ada rules. */
2110 static struct value
*
2111 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2114 CORE_ADDR base
= value_as_address (array_ptr
)
2115 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2116 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2117 struct type
*index_type
=
2118 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2120 struct type
*slice_type
=
2121 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2122 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2126 static struct value
*
2127 ada_value_slice (struct value
*array
, int low
, int high
)
2129 struct type
*type
= value_type (array
);
2130 struct type
*index_type
=
2131 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2132 struct type
*slice_type
=
2133 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2134 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2137 /* If type is a record type in the form of a standard GNAT array
2138 descriptor, returns the number of dimensions for type. If arr is a
2139 simple array, returns the number of "array of"s that prefix its
2140 type designation. Otherwise, returns 0. */
2143 ada_array_arity (struct type
*type
)
2150 type
= desc_base_type (type
);
2153 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2154 return desc_arity (desc_bounds_type (type
));
2156 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2159 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2165 /* If TYPE is a record type in the form of a standard GNAT array
2166 descriptor or a simple array type, returns the element type for
2167 TYPE after indexing by NINDICES indices, or by all indices if
2168 NINDICES is -1. Otherwise, returns NULL. */
2171 ada_array_element_type (struct type
*type
, int nindices
)
2173 type
= desc_base_type (type
);
2175 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2178 struct type
*p_array_type
;
2180 p_array_type
= desc_data_type (type
);
2182 k
= ada_array_arity (type
);
2186 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2187 if (nindices
>= 0 && k
> nindices
)
2189 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2190 while (k
> 0 && p_array_type
!= NULL
)
2192 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2195 return p_array_type
;
2197 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2199 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2201 type
= TYPE_TARGET_TYPE (type
);
2210 /* The type of nth index in arrays of given type (n numbering from 1).
2211 Does not examine memory. */
2214 ada_index_type (struct type
*type
, int n
)
2216 struct type
*result_type
;
2218 type
= desc_base_type (type
);
2220 if (n
> ada_array_arity (type
))
2223 if (ada_is_simple_array_type (type
))
2227 for (i
= 1; i
< n
; i
+= 1)
2228 type
= TYPE_TARGET_TYPE (type
);
2229 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2230 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2231 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2232 perhaps stabsread.c would make more sense. */
2233 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2234 result_type
= builtin_type_int
;
2239 return desc_index_type (desc_bounds_type (type
), n
);
2242 /* Given that arr is an array type, returns the lower bound of the
2243 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2244 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2245 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2246 bounds type. It works for other arrays with bounds supplied by
2247 run-time quantities other than discriminants. */
2250 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2251 struct type
** typep
)
2254 struct type
*index_type_desc
;
2256 if (ada_is_packed_array_type (arr_type
))
2257 arr_type
= decode_packed_array_type (arr_type
);
2259 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2262 *typep
= builtin_type_int
;
2263 return (LONGEST
) - which
;
2266 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2267 type
= TYPE_TARGET_TYPE (arr_type
);
2271 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2272 if (index_type_desc
== NULL
)
2274 struct type
*range_type
;
2275 struct type
*index_type
;
2279 type
= TYPE_TARGET_TYPE (type
);
2283 range_type
= TYPE_INDEX_TYPE (type
);
2284 index_type
= TYPE_TARGET_TYPE (range_type
);
2285 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2286 index_type
= builtin_type_long
;
2288 *typep
= index_type
;
2290 (LONGEST
) (which
== 0
2291 ? TYPE_LOW_BOUND (range_type
)
2292 : TYPE_HIGH_BOUND (range_type
));
2296 struct type
*index_type
=
2297 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2298 NULL
, TYPE_OBJFILE (arr_type
));
2300 *typep
= TYPE_TARGET_TYPE (index_type
);
2302 (LONGEST
) (which
== 0
2303 ? TYPE_LOW_BOUND (index_type
)
2304 : TYPE_HIGH_BOUND (index_type
));
2308 /* Given that arr is an array value, returns the lower bound of the
2309 nth index (numbering from 1) if which is 0, and the upper bound if
2310 which is 1. This routine will also work for arrays with bounds
2311 supplied by run-time quantities other than discriminants. */
2314 ada_array_bound (struct value
*arr
, int n
, int which
)
2316 struct type
*arr_type
= value_type (arr
);
2318 if (ada_is_packed_array_type (arr_type
))
2319 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2320 else if (ada_is_simple_array_type (arr_type
))
2323 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2324 return value_from_longest (type
, v
);
2327 return desc_one_bound (desc_bounds (arr
), n
, which
);
2330 /* Given that arr is an array value, returns the length of the
2331 nth index. This routine will also work for arrays with bounds
2332 supplied by run-time quantities other than discriminants.
2333 Does not work for arrays indexed by enumeration types with representation
2334 clauses at the moment. */
2337 ada_array_length (struct value
*arr
, int n
)
2339 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2341 if (ada_is_packed_array_type (arr_type
))
2342 return ada_array_length (decode_packed_array (arr
), n
);
2344 if (ada_is_simple_array_type (arr_type
))
2348 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2349 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2350 return value_from_longest (type
, v
);
2354 value_from_longest (builtin_type_int
,
2355 value_as_long (desc_one_bound (desc_bounds (arr
),
2357 - value_as_long (desc_one_bound (desc_bounds (arr
),
2361 /* An empty array whose type is that of ARR_TYPE (an array type),
2362 with bounds LOW to LOW-1. */
2364 static struct value
*
2365 empty_array (struct type
*arr_type
, int low
)
2367 struct type
*index_type
=
2368 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2370 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2371 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2375 /* Name resolution */
2377 /* The "decoded" name for the user-definable Ada operator corresponding
2381 ada_decoded_op_name (enum exp_opcode op
)
2385 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2387 if (ada_opname_table
[i
].op
== op
)
2388 return ada_opname_table
[i
].decoded
;
2390 error (_("Could not find operator name for opcode"));
2394 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2395 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2396 undefined namespace) and converts operators that are
2397 user-defined into appropriate function calls. If CONTEXT_TYPE is
2398 non-null, it provides a preferred result type [at the moment, only
2399 type void has any effect---causing procedures to be preferred over
2400 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2401 return type is preferred. May change (expand) *EXP. */
2404 resolve (struct expression
**expp
, int void_context_p
)
2408 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2411 /* Resolve the operator of the subexpression beginning at
2412 position *POS of *EXPP. "Resolving" consists of replacing
2413 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2414 with their resolutions, replacing built-in operators with
2415 function calls to user-defined operators, where appropriate, and,
2416 when DEPROCEDURE_P is non-zero, converting function-valued variables
2417 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2418 are as in ada_resolve, above. */
2420 static struct value
*
2421 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2422 struct type
*context_type
)
2426 struct expression
*exp
; /* Convenience: == *expp. */
2427 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2428 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2429 int nargs
; /* Number of operands. */
2435 /* Pass one: resolve operands, saving their types and updating *pos. */
2439 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2440 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2445 resolve_subexp (expp
, pos
, 0, NULL
);
2447 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2452 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2457 resolve_subexp (expp
, pos
, 0, NULL
);
2460 case OP_ATR_MODULUS
:
2490 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2492 resolve_subexp (expp
, pos
, 1, NULL
);
2494 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2512 case BINOP_LOGICAL_AND
:
2513 case BINOP_LOGICAL_OR
:
2514 case BINOP_BITWISE_AND
:
2515 case BINOP_BITWISE_IOR
:
2516 case BINOP_BITWISE_XOR
:
2519 case BINOP_NOTEQUAL
:
2526 case BINOP_SUBSCRIPT
:
2534 case UNOP_LOGICAL_NOT
:
2551 case OP_INTERNALVAR
:
2560 case STRUCTOP_STRUCT
:
2561 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2567 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2572 case TERNOP_IN_RANGE
:
2577 case BINOP_IN_BOUNDS
:
2583 error (_("Unexpected operator during name resolution"));
2586 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2587 for (i
= 0; i
< nargs
; i
+= 1)
2588 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2592 /* Pass two: perform any resolution on principal operator. */
2599 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2601 struct ada_symbol_info
*candidates
;
2605 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2606 (exp
->elts
[pc
+ 2].symbol
),
2607 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2610 if (n_candidates
> 1)
2612 /* Types tend to get re-introduced locally, so if there
2613 are any local symbols that are not types, first filter
2616 for (j
= 0; j
< n_candidates
; j
+= 1)
2617 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2623 case LOC_REGPARM_ADDR
:
2627 case LOC_BASEREG_ARG
:
2629 case LOC_COMPUTED_ARG
:
2635 if (j
< n_candidates
)
2638 while (j
< n_candidates
)
2640 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2642 candidates
[j
] = candidates
[n_candidates
- 1];
2651 if (n_candidates
== 0)
2652 error (_("No definition found for %s"),
2653 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2654 else if (n_candidates
== 1)
2656 else if (deprocedure_p
2657 && !is_nonfunction (candidates
, n_candidates
))
2659 i
= ada_resolve_function
2660 (candidates
, n_candidates
, NULL
, 0,
2661 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2664 error (_("Could not find a match for %s"),
2665 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2669 printf_filtered (_("Multiple matches for %s\n"),
2670 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2671 user_select_syms (candidates
, n_candidates
, 1);
2675 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2676 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2677 if (innermost_block
== NULL
2678 || contained_in (candidates
[i
].block
, innermost_block
))
2679 innermost_block
= candidates
[i
].block
;
2683 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2686 replace_operator_with_call (expp
, pc
, 0, 0,
2687 exp
->elts
[pc
+ 2].symbol
,
2688 exp
->elts
[pc
+ 1].block
);
2695 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2696 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2698 struct ada_symbol_info
*candidates
;
2702 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2703 (exp
->elts
[pc
+ 5].symbol
),
2704 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2706 if (n_candidates
== 1)
2710 i
= ada_resolve_function
2711 (candidates
, n_candidates
,
2713 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2716 error (_("Could not find a match for %s"),
2717 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2720 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2721 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2722 if (innermost_block
== NULL
2723 || contained_in (candidates
[i
].block
, innermost_block
))
2724 innermost_block
= candidates
[i
].block
;
2735 case BINOP_BITWISE_AND
:
2736 case BINOP_BITWISE_IOR
:
2737 case BINOP_BITWISE_XOR
:
2739 case BINOP_NOTEQUAL
:
2747 case UNOP_LOGICAL_NOT
:
2749 if (possible_user_operator_p (op
, argvec
))
2751 struct ada_symbol_info
*candidates
;
2755 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2756 (struct block
*) NULL
, VAR_DOMAIN
,
2758 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2759 ada_decoded_op_name (op
), NULL
);
2763 replace_operator_with_call (expp
, pc
, nargs
, 1,
2764 candidates
[i
].sym
, candidates
[i
].block
);
2774 return evaluate_subexp_type (exp
, pos
);
2777 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2778 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2779 a non-pointer. A type of 'void' (which is never a valid expression type)
2780 by convention matches anything. */
2781 /* The term "match" here is rather loose. The match is heuristic and
2782 liberal. FIXME: TOO liberal, in fact. */
2785 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2787 ftype
= ada_check_typedef (ftype
);
2788 atype
= ada_check_typedef (atype
);
2790 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2791 ftype
= TYPE_TARGET_TYPE (ftype
);
2792 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2793 atype
= TYPE_TARGET_TYPE (atype
);
2795 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2796 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2799 switch (TYPE_CODE (ftype
))
2804 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2805 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2806 TYPE_TARGET_TYPE (atype
), 0);
2809 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2811 case TYPE_CODE_ENUM
:
2812 case TYPE_CODE_RANGE
:
2813 switch (TYPE_CODE (atype
))
2816 case TYPE_CODE_ENUM
:
2817 case TYPE_CODE_RANGE
:
2823 case TYPE_CODE_ARRAY
:
2824 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2825 || ada_is_array_descriptor_type (atype
));
2827 case TYPE_CODE_STRUCT
:
2828 if (ada_is_array_descriptor_type (ftype
))
2829 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2830 || ada_is_array_descriptor_type (atype
));
2832 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2833 && !ada_is_array_descriptor_type (atype
));
2835 case TYPE_CODE_UNION
:
2837 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2841 /* Return non-zero if the formals of FUNC "sufficiently match" the
2842 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2843 may also be an enumeral, in which case it is treated as a 0-
2844 argument function. */
2847 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2850 struct type
*func_type
= SYMBOL_TYPE (func
);
2852 if (SYMBOL_CLASS (func
) == LOC_CONST
2853 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2854 return (n_actuals
== 0);
2855 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2858 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2861 for (i
= 0; i
< n_actuals
; i
+= 1)
2863 if (actuals
[i
] == NULL
)
2867 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2868 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
2870 if (!ada_type_match (ftype
, atype
, 1))
2877 /* False iff function type FUNC_TYPE definitely does not produce a value
2878 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2879 FUNC_TYPE is not a valid function type with a non-null return type
2880 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2883 return_match (struct type
*func_type
, struct type
*context_type
)
2885 struct type
*return_type
;
2887 if (func_type
== NULL
)
2890 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2891 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2893 return_type
= base_type (func_type
);
2894 if (return_type
== NULL
)
2897 context_type
= base_type (context_type
);
2899 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2900 return context_type
== NULL
|| return_type
== context_type
;
2901 else if (context_type
== NULL
)
2902 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2904 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2908 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
2909 function (if any) that matches the types of the NARGS arguments in
2910 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2911 that returns that type, then eliminate matches that don't. If
2912 CONTEXT_TYPE is void and there is at least one match that does not
2913 return void, eliminate all matches that do.
2915 Asks the user if there is more than one match remaining. Returns -1
2916 if there is no such symbol or none is selected. NAME is used
2917 solely for messages. May re-arrange and modify SYMS in
2918 the process; the index returned is for the modified vector. */
2921 ada_resolve_function (struct ada_symbol_info syms
[],
2922 int nsyms
, struct value
**args
, int nargs
,
2923 const char *name
, struct type
*context_type
)
2926 int m
; /* Number of hits */
2927 struct type
*fallback
;
2928 struct type
*return_type
;
2930 return_type
= context_type
;
2931 if (context_type
== NULL
)
2932 fallback
= builtin_type_void
;
2939 for (k
= 0; k
< nsyms
; k
+= 1)
2941 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
2943 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
2944 && return_match (type
, return_type
))
2950 if (m
> 0 || return_type
== fallback
)
2953 return_type
= fallback
;
2960 printf_filtered (_("Multiple matches for %s\n"), name
);
2961 user_select_syms (syms
, m
, 1);
2967 /* Returns true (non-zero) iff decoded name N0 should appear before N1
2968 in a listing of choices during disambiguation (see sort_choices, below).
2969 The idea is that overloadings of a subprogram name from the
2970 same package should sort in their source order. We settle for ordering
2971 such symbols by their trailing number (__N or $N). */
2974 encoded_ordered_before (char *N0
, char *N1
)
2978 else if (N0
== NULL
)
2983 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2985 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2987 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2988 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2992 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2995 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2997 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
2998 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3000 return (strcmp (N0
, N1
) < 0);
3004 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3008 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3011 for (i
= 1; i
< nsyms
; i
+= 1)
3013 struct ada_symbol_info sym
= syms
[i
];
3016 for (j
= i
- 1; j
>= 0; j
-= 1)
3018 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3019 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3021 syms
[j
+ 1] = syms
[j
];
3027 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3028 by asking the user (if necessary), returning the number selected,
3029 and setting the first elements of SYMS items. Error if no symbols
3032 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3033 to be re-integrated one of these days. */
3036 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3039 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3041 int first_choice
= (max_results
== 1) ? 1 : 2;
3043 if (max_results
< 1)
3044 error (_("Request to select 0 symbols!"));
3048 printf_unfiltered (_("[0] cancel\n"));
3049 if (max_results
> 1)
3050 printf_unfiltered (_("[1] all\n"));
3052 sort_choices (syms
, nsyms
);
3054 for (i
= 0; i
< nsyms
; i
+= 1)
3056 if (syms
[i
].sym
== NULL
)
3059 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3061 struct symtab_and_line sal
=
3062 find_function_start_sal (syms
[i
].sym
, 1);
3063 if (sal
.symtab
== NULL
)
3064 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3066 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3069 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3070 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3071 sal
.symtab
->filename
, sal
.line
);
3077 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3078 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3079 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3080 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3082 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3083 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3085 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3086 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3087 else if (is_enumeral
3088 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3090 printf_unfiltered ("[%d] ", i
+ first_choice
);
3091 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3093 printf_unfiltered (_("'(%s) (enumeral)\n"),
3094 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3096 else if (symtab
!= NULL
)
3097 printf_unfiltered (is_enumeral
3098 ? _("[%d] %s in %s (enumeral)\n")
3099 : _("[%d] %s at %s:?\n"),
3101 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3104 printf_unfiltered (is_enumeral
3105 ? _("[%d] %s (enumeral)\n")
3106 : _("[%d] %s at ?\n"),
3108 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3112 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3115 for (i
= 0; i
< n_chosen
; i
+= 1)
3116 syms
[i
] = syms
[chosen
[i
]];
3121 /* Read and validate a set of numeric choices from the user in the
3122 range 0 .. N_CHOICES-1. Place the results in increasing
3123 order in CHOICES[0 .. N-1], and return N.
3125 The user types choices as a sequence of numbers on one line
3126 separated by blanks, encoding them as follows:
3128 + A choice of 0 means to cancel the selection, throwing an error.
3129 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3130 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3132 The user is not allowed to choose more than MAX_RESULTS values.
3134 ANNOTATION_SUFFIX, if present, is used to annotate the input
3135 prompts (for use with the -f switch). */
3138 get_selections (int *choices
, int n_choices
, int max_results
,
3139 int is_all_choice
, char *annotation_suffix
)
3144 int first_choice
= is_all_choice
? 2 : 1;
3146 prompt
= getenv ("PS2");
3150 printf_unfiltered ("%s ", prompt
);
3151 gdb_flush (gdb_stdout
);
3153 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3156 error_no_arg (_("one or more choice numbers"));
3160 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3161 order, as given in args. Choices are validated. */
3167 while (isspace (*args
))
3169 if (*args
== '\0' && n_chosen
== 0)
3170 error_no_arg (_("one or more choice numbers"));
3171 else if (*args
== '\0')
3174 choice
= strtol (args
, &args2
, 10);
3175 if (args
== args2
|| choice
< 0
3176 || choice
> n_choices
+ first_choice
- 1)
3177 error (_("Argument must be choice number"));
3181 error (_("cancelled"));
3183 if (choice
< first_choice
)
3185 n_chosen
= n_choices
;
3186 for (j
= 0; j
< n_choices
; j
+= 1)
3190 choice
-= first_choice
;
3192 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3196 if (j
< 0 || choice
!= choices
[j
])
3199 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3200 choices
[k
+ 1] = choices
[k
];
3201 choices
[j
+ 1] = choice
;
3206 if (n_chosen
> max_results
)
3207 error (_("Select no more than %d of the above"), max_results
);
3212 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3213 on the function identified by SYM and BLOCK, and taking NARGS
3214 arguments. Update *EXPP as needed to hold more space. */
3217 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3218 int oplen
, struct symbol
*sym
,
3219 struct block
*block
)
3221 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3222 symbol, -oplen for operator being replaced). */
3223 struct expression
*newexp
= (struct expression
*)
3224 xmalloc (sizeof (struct expression
)
3225 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3226 struct expression
*exp
= *expp
;
3228 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3229 newexp
->language_defn
= exp
->language_defn
;
3230 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3231 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3232 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3234 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3235 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3237 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3238 newexp
->elts
[pc
+ 4].block
= block
;
3239 newexp
->elts
[pc
+ 5].symbol
= sym
;
3245 /* Type-class predicates */
3247 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3251 numeric_type_p (struct type
*type
)
3257 switch (TYPE_CODE (type
))
3262 case TYPE_CODE_RANGE
:
3263 return (type
== TYPE_TARGET_TYPE (type
)
3264 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3271 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3274 integer_type_p (struct type
*type
)
3280 switch (TYPE_CODE (type
))
3284 case TYPE_CODE_RANGE
:
3285 return (type
== TYPE_TARGET_TYPE (type
)
3286 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3293 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3296 scalar_type_p (struct type
*type
)
3302 switch (TYPE_CODE (type
))
3305 case TYPE_CODE_RANGE
:
3306 case TYPE_CODE_ENUM
:
3315 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3318 discrete_type_p (struct type
*type
)
3324 switch (TYPE_CODE (type
))
3327 case TYPE_CODE_RANGE
:
3328 case TYPE_CODE_ENUM
:
3336 /* Returns non-zero if OP with operands in the vector ARGS could be
3337 a user-defined function. Errs on the side of pre-defined operators
3338 (i.e., result 0). */
3341 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3343 struct type
*type0
=
3344 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3345 struct type
*type1
=
3346 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3360 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3364 case BINOP_BITWISE_AND
:
3365 case BINOP_BITWISE_IOR
:
3366 case BINOP_BITWISE_XOR
:
3367 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3370 case BINOP_NOTEQUAL
:
3375 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3379 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3380 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3381 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3382 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3383 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3384 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
))
3385 != TYPE_CODE_ARRAY
))));
3388 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3392 case UNOP_LOGICAL_NOT
:
3394 return (!numeric_type_p (type0
));
3401 /* NOTE: In the following, we assume that a renaming type's name may
3402 have an ___XD suffix. It would be nice if this went away at some
3405 /* If TYPE encodes a renaming, returns the renaming suffix, which
3406 is XR for an object renaming, XRP for a procedure renaming, XRE for
3407 an exception renaming, and XRS for a subprogram renaming. Returns
3408 NULL if NAME encodes none of these. */
3411 ada_renaming_type (struct type
*type
)
3413 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3415 const char *name
= type_name_no_tag (type
);
3416 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3418 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3427 /* Return non-zero iff SYM encodes an object renaming. */
3430 ada_is_object_renaming (struct symbol
*sym
)
3432 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3433 return renaming_type
!= NULL
3434 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3437 /* Assuming that SYM encodes a non-object renaming, returns the original
3438 name of the renamed entity. The name is good until the end of
3442 ada_simple_renamed_entity (struct symbol
*sym
)
3445 const char *raw_name
;
3449 type
= SYMBOL_TYPE (sym
);
3450 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3451 error (_("Improperly encoded renaming."));
3453 raw_name
= TYPE_FIELD_NAME (type
, 0);
3454 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3456 error (_("Improperly encoded renaming."));
3458 result
= xmalloc (len
+ 1);
3459 strncpy (result
, raw_name
, len
);
3460 result
[len
] = '\000';
3465 /* Evaluation: Function Calls */
3467 /* Return an lvalue containing the value VAL. This is the identity on
3468 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3469 on the stack, using and updating *SP as the stack pointer, and
3470 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3472 static struct value
*
3473 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3475 if (! VALUE_LVAL (val
))
3477 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3479 /* The following is taken from the structure-return code in
3480 call_function_by_hand. FIXME: Therefore, some refactoring seems
3482 if (INNER_THAN (1, 2))
3484 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3485 reserving sufficient space. */
3487 if (gdbarch_frame_align_p (current_gdbarch
))
3488 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3489 VALUE_ADDRESS (val
) = *sp
;
3493 /* Stack grows upward. Align the frame, allocate space, and
3494 then again, re-align the frame. */
3495 if (gdbarch_frame_align_p (current_gdbarch
))
3496 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3497 VALUE_ADDRESS (val
) = *sp
;
3499 if (gdbarch_frame_align_p (current_gdbarch
))
3500 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3503 write_memory (VALUE_ADDRESS (val
), VALUE_CONTENTS_RAW (val
), len
);
3509 /* Return the value ACTUAL, converted to be an appropriate value for a
3510 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3511 allocating any necessary descriptors (fat pointers), or copies of
3512 values not residing in memory, updating it as needed. */
3514 static struct value
*
3515 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3518 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3519 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3520 struct type
*formal_target
=
3521 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3522 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3523 struct type
*actual_target
=
3524 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3525 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3527 if (ada_is_array_descriptor_type (formal_target
)
3528 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3529 return make_array_descriptor (formal_type
, actual
, sp
);
3530 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3532 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3533 && ada_is_array_descriptor_type (actual_target
))
3534 return desc_data (actual
);
3535 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3537 if (VALUE_LVAL (actual
) != lval_memory
)
3540 actual_type
= ada_check_typedef (value_type (actual
));
3541 val
= allocate_value (actual_type
);
3542 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3543 (char *) VALUE_CONTENTS (actual
),
3544 TYPE_LENGTH (actual_type
));
3545 actual
= ensure_lval (val
, sp
);
3547 return value_addr (actual
);
3550 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3551 return ada_value_ind (actual
);
3557 /* Push a descriptor of type TYPE for array value ARR on the stack at
3558 *SP, updating *SP to reflect the new descriptor. Return either
3559 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3560 to-descriptor type rather than a descriptor type), a struct value *
3561 representing a pointer to this descriptor. */
3563 static struct value
*
3564 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3566 struct type
*bounds_type
= desc_bounds_type (type
);
3567 struct type
*desc_type
= desc_base_type (type
);
3568 struct value
*descriptor
= allocate_value (desc_type
);
3569 struct value
*bounds
= allocate_value (bounds_type
);
3572 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3574 modify_general_field (VALUE_CONTENTS (bounds
),
3575 value_as_long (ada_array_bound (arr
, i
, 0)),
3576 desc_bound_bitpos (bounds_type
, i
, 0),
3577 desc_bound_bitsize (bounds_type
, i
, 0));
3578 modify_general_field (VALUE_CONTENTS (bounds
),
3579 value_as_long (ada_array_bound (arr
, i
, 1)),
3580 desc_bound_bitpos (bounds_type
, i
, 1),
3581 desc_bound_bitsize (bounds_type
, i
, 1));
3584 bounds
= ensure_lval (bounds
, sp
);
3586 modify_general_field (VALUE_CONTENTS (descriptor
),
3587 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3588 fat_pntr_data_bitpos (desc_type
),
3589 fat_pntr_data_bitsize (desc_type
));
3591 modify_general_field (VALUE_CONTENTS (descriptor
),
3592 VALUE_ADDRESS (bounds
),
3593 fat_pntr_bounds_bitpos (desc_type
),
3594 fat_pntr_bounds_bitsize (desc_type
));
3596 descriptor
= ensure_lval (descriptor
, sp
);
3598 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3599 return value_addr (descriptor
);
3605 /* Assuming a dummy frame has been established on the target, perform any
3606 conversions needed for calling function FUNC on the NARGS actual
3607 parameters in ARGS, other than standard C conversions. Does
3608 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3609 does not match the number of arguments expected. Use *SP as a
3610 stack pointer for additional data that must be pushed, updating its
3614 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3619 if (TYPE_NFIELDS (value_type (func
)) == 0
3620 || nargs
!= TYPE_NFIELDS (value_type (func
)))
3623 for (i
= 0; i
< nargs
; i
+= 1)
3625 convert_actual (args
[i
], TYPE_FIELD_TYPE (value_type (func
), i
), sp
);
3628 /* Dummy definitions for an experimental caching module that is not
3629 * used in the public sources. */
3632 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3633 struct symbol
**sym
, struct block
**block
,
3634 struct symtab
**symtab
)
3640 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3641 struct block
*block
, struct symtab
*symtab
)
3647 /* Return the result of a standard (literal, C-like) lookup of NAME in
3648 given DOMAIN, visible from lexical block BLOCK. */
3650 static struct symbol
*
3651 standard_lookup (const char *name
, const struct block
*block
,
3655 struct symtab
*symtab
;
3657 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3660 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3661 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3666 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3667 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3668 since they contend in overloading in the same way. */
3670 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3674 for (i
= 0; i
< n
; i
+= 1)
3675 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3676 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3677 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3683 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3684 struct types. Otherwise, they may not. */
3687 equiv_types (struct type
*type0
, struct type
*type1
)
3691 if (type0
== NULL
|| type1
== NULL
3692 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3694 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3695 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3696 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3697 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3703 /* True iff SYM0 represents the same entity as SYM1, or one that is
3704 no more defined than that of SYM1. */
3707 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3711 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3712 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3715 switch (SYMBOL_CLASS (sym0
))
3721 struct type
*type0
= SYMBOL_TYPE (sym0
);
3722 struct type
*type1
= SYMBOL_TYPE (sym1
);
3723 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3724 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3725 int len0
= strlen (name0
);
3727 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3728 && (equiv_types (type0
, type1
)
3729 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3730 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3733 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3734 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3740 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3741 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3744 add_defn_to_vec (struct obstack
*obstackp
,
3746 struct block
*block
, struct symtab
*symtab
)
3750 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3752 if (SYMBOL_TYPE (sym
) != NULL
)
3753 SYMBOL_TYPE (sym
) = ada_check_typedef (SYMBOL_TYPE (sym
));
3754 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3756 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3758 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3760 prevDefns
[i
].sym
= sym
;
3761 prevDefns
[i
].block
= block
;
3762 prevDefns
[i
].symtab
= symtab
;
3768 struct ada_symbol_info info
;
3772 info
.symtab
= symtab
;
3773 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3777 /* Number of ada_symbol_info structures currently collected in
3778 current vector in *OBSTACKP. */
3781 num_defns_collected (struct obstack
*obstackp
)
3783 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3786 /* Vector of ada_symbol_info structures currently collected in current
3787 vector in *OBSTACKP. If FINISH, close off the vector and return
3788 its final address. */
3790 static struct ada_symbol_info
*
3791 defns_collected (struct obstack
*obstackp
, int finish
)
3794 return obstack_finish (obstackp
);
3796 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3799 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3800 Check the global symbols if GLOBAL, the static symbols if not.
3801 Do wild-card match if WILD. */
3803 static struct partial_symbol
*
3804 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3805 int global
, domain_enum
namespace, int wild
)
3807 struct partial_symbol
**start
;
3808 int name_len
= strlen (name
);
3809 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3818 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3819 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3823 for (i
= 0; i
< length
; i
+= 1)
3825 struct partial_symbol
*psym
= start
[i
];
3827 if (SYMBOL_DOMAIN (psym
) == namespace
3828 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3842 int M
= (U
+ i
) >> 1;
3843 struct partial_symbol
*psym
= start
[M
];
3844 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3846 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3848 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
3859 struct partial_symbol
*psym
= start
[i
];
3861 if (SYMBOL_DOMAIN (psym
) == namespace)
3863 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
3871 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3885 int M
= (U
+ i
) >> 1;
3886 struct partial_symbol
*psym
= start
[M
];
3887 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
3889 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
3891 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
3902 struct partial_symbol
*psym
= start
[i
];
3904 if (SYMBOL_DOMAIN (psym
) == namespace)
3908 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
3911 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
3913 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
3923 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3933 /* Find a symbol table containing symbol SYM or NULL if none. */
3935 static struct symtab
*
3936 symtab_for_sym (struct symbol
*sym
)
3939 struct objfile
*objfile
;
3941 struct symbol
*tmp_sym
;
3942 struct dict_iterator iter
;
3945 ALL_SYMTABS (objfile
, s
)
3947 switch (SYMBOL_CLASS (sym
))
3955 case LOC_CONST_BYTES
:
3956 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3957 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3959 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3960 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3966 switch (SYMBOL_CLASS (sym
))
3972 case LOC_REGPARM_ADDR
:
3977 case LOC_BASEREG_ARG
:
3979 case LOC_COMPUTED_ARG
:
3980 for (j
= FIRST_LOCAL_BLOCK
;
3981 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3983 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3984 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3995 /* Return a minimal symbol matching NAME according to Ada decoding
3996 rules. Returns NULL if there is no such minimal symbol. Names
3997 prefixed with "standard__" are handled specially: "standard__" is
3998 first stripped off, and only static and global symbols are searched. */
4000 struct minimal_symbol
*
4001 ada_lookup_simple_minsym (const char *name
)
4003 struct objfile
*objfile
;
4004 struct minimal_symbol
*msymbol
;
4007 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4009 name
+= sizeof ("standard__") - 1;
4013 wild_match
= (strstr (name
, "__") == NULL
);
4015 ALL_MSYMBOLS (objfile
, msymbol
)
4017 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4018 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4025 /* For all subprograms that statically enclose the subprogram of the
4026 selected frame, add symbols matching identifier NAME in DOMAIN
4027 and their blocks to the list of data in OBSTACKP, as for
4028 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4032 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4033 const char *name
, domain_enum
namespace,
4038 /* FIXME: The next two routines belong in symtab.c */
4041 restore_language (void *lang
)
4043 set_language ((enum language
) lang
);
4046 /* As for lookup_symbol, but performed as if the current language
4050 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4051 domain_enum domain
, enum language lang
,
4052 int *is_a_field_of_this
, struct symtab
**symtab
)
4054 struct cleanup
*old_chain
4055 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4056 struct symbol
*result
;
4057 set_language (lang
);
4058 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4059 do_cleanups (old_chain
);
4063 /* True if TYPE is definitely an artificial type supplied to a symbol
4064 for which no debugging information was given in the symbol file. */
4067 is_nondebugging_type (struct type
*type
)
4069 char *name
= ada_type_name (type
);
4070 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4073 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4074 duplicate other symbols in the list (The only case I know of where
4075 this happens is when object files containing stabs-in-ecoff are
4076 linked with files containing ordinary ecoff debugging symbols (or no
4077 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4078 Returns the number of items in the modified list. */
4081 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4088 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4089 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4090 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4092 for (j
= 0; j
< nsyms
; j
+= 1)
4095 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4096 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4097 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4098 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4099 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4100 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4103 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4104 syms
[k
- 1] = syms
[k
];
4117 /* Given a type that corresponds to a renaming entity, use the type name
4118 to extract the scope (package name or function name, fully qualified,
4119 and following the GNAT encoding convention) where this renaming has been
4120 defined. The string returned needs to be deallocated after use. */
4123 xget_renaming_scope (struct type
*renaming_type
)
4125 /* The renaming types adhere to the following convention:
4126 <scope>__<rename>___<XR extension>.
4127 So, to extract the scope, we search for the "___XR" extension,
4128 and then backtrack until we find the first "__". */
4130 const char *name
= type_name_no_tag (renaming_type
);
4131 char *suffix
= strstr (name
, "___XR");
4136 /* Now, backtrack a bit until we find the first "__". Start looking
4137 at suffix - 3, as the <rename> part is at least one character long. */
4139 for (last
= suffix
- 3; last
> name
; last
--)
4140 if (last
[0] == '_' && last
[1] == '_')
4143 /* Make a copy of scope and return it. */
4145 scope_len
= last
- name
;
4146 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4148 strncpy (scope
, name
, scope_len
);
4149 scope
[scope_len
] = '\0';
4154 /* Return nonzero if NAME corresponds to a package name. */
4157 is_package_name (const char *name
)
4159 /* Here, We take advantage of the fact that no symbols are generated
4160 for packages, while symbols are generated for each function.
4161 So the condition for NAME represent a package becomes equivalent
4162 to NAME not existing in our list of symbols. There is only one
4163 small complication with library-level functions (see below). */
4167 /* If it is a function that has not been defined at library level,
4168 then we should be able to look it up in the symbols. */
4169 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4172 /* Library-level function names start with "_ada_". See if function
4173 "_ada_" followed by NAME can be found. */
4175 /* Do a quick check that NAME does not contain "__", since library-level
4176 functions names can not contain "__" in them. */
4177 if (strstr (name
, "__") != NULL
)
4180 fun_name
= xstrprintf ("_ada_%s", name
);
4182 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4185 /* Return nonzero if SYM corresponds to a renaming entity that is
4186 visible from FUNCTION_NAME. */
4189 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4191 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4193 make_cleanup (xfree
, scope
);
4195 /* If the rename has been defined in a package, then it is visible. */
4196 if (is_package_name (scope
))
4199 /* Check that the rename is in the current function scope by checking
4200 that its name starts with SCOPE. */
4202 /* If the function name starts with "_ada_", it means that it is
4203 a library-level function. Strip this prefix before doing the
4204 comparison, as the encoding for the renaming does not contain
4206 if (strncmp (function_name
, "_ada_", 5) == 0)
4209 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4212 /* Iterates over the SYMS list and remove any entry that corresponds to
4213 a renaming entity that is not visible from the function associated
4217 GNAT emits a type following a specified encoding for each renaming
4218 entity. Unfortunately, STABS currently does not support the definition
4219 of types that are local to a given lexical block, so all renamings types
4220 are emitted at library level. As a consequence, if an application
4221 contains two renaming entities using the same name, and a user tries to
4222 print the value of one of these entities, the result of the ada symbol
4223 lookup will also contain the wrong renaming type.
4225 This function partially covers for this limitation by attempting to
4226 remove from the SYMS list renaming symbols that should be visible
4227 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4228 method with the current information available. The implementation
4229 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4231 - When the user tries to print a rename in a function while there
4232 is another rename entity defined in a package: Normally, the
4233 rename in the function has precedence over the rename in the
4234 package, so the latter should be removed from the list. This is
4235 currently not the case.
4237 - This function will incorrectly remove valid renames if
4238 the CURRENT_BLOCK corresponds to a function which symbol name
4239 has been changed by an "Export" pragma. As a consequence,
4240 the user will be unable to print such rename entities. */
4243 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4244 int nsyms
, struct block
*current_block
)
4246 struct symbol
*current_function
;
4247 char *current_function_name
;
4250 /* Extract the function name associated to CURRENT_BLOCK.
4251 Abort if unable to do so. */
4253 if (current_block
== NULL
)
4256 current_function
= block_function (current_block
);
4257 if (current_function
== NULL
)
4260 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4261 if (current_function_name
== NULL
)
4264 /* Check each of the symbols, and remove it from the list if it is
4265 a type corresponding to a renaming that is out of the scope of
4266 the current block. */
4271 if (ada_is_object_renaming (syms
[i
].sym
)
4272 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4275 for (j
= i
+ 1; j
< nsyms
; j
++)
4276 syms
[j
- 1] = syms
[j
];
4286 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4287 scope and in global scopes, returning the number of matches. Sets
4288 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4289 indicating the symbols found and the blocks and symbol tables (if
4290 any) in which they were found. This vector are transient---good only to
4291 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4292 symbol match within the nest of blocks whose innermost member is BLOCK0,
4293 is the one match returned (no other matches in that or
4294 enclosing blocks is returned). If there are any matches in or
4295 surrounding BLOCK0, then these alone are returned. Otherwise, the
4296 search extends to global and file-scope (static) symbol tables.
4297 Names prefixed with "standard__" are handled specially: "standard__"
4298 is first stripped off, and only static and global symbols are searched. */
4301 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4302 domain_enum
namespace,
4303 struct ada_symbol_info
**results
)
4307 struct partial_symtab
*ps
;
4308 struct blockvector
*bv
;
4309 struct objfile
*objfile
;
4310 struct block
*block
;
4312 struct minimal_symbol
*msymbol
;
4318 obstack_free (&symbol_list_obstack
, NULL
);
4319 obstack_init (&symbol_list_obstack
);
4323 /* Search specified block and its superiors. */
4325 wild_match
= (strstr (name0
, "__") == NULL
);
4327 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4328 needed, but adding const will
4329 have a cascade effect. */
4330 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4334 name
= name0
+ sizeof ("standard__") - 1;
4338 while (block
!= NULL
)
4341 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4342 namespace, NULL
, NULL
, wild_match
);
4344 /* If we found a non-function match, assume that's the one. */
4345 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4346 num_defns_collected (&symbol_list_obstack
)))
4349 block
= BLOCK_SUPERBLOCK (block
);
4352 /* If no luck so far, try to find NAME as a local symbol in some lexically
4353 enclosing subprogram. */
4354 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4355 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4356 name
, namespace, wild_match
);
4358 /* If we found ANY matches among non-global symbols, we're done. */
4360 if (num_defns_collected (&symbol_list_obstack
) > 0)
4364 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4367 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4371 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4372 tables, and psymtab's. */
4374 ALL_SYMTABS (objfile
, s
)
4379 bv
= BLOCKVECTOR (s
);
4380 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4381 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4382 objfile
, s
, wild_match
);
4385 if (namespace == VAR_DOMAIN
)
4387 ALL_MSYMBOLS (objfile
, msymbol
)
4389 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4391 switch (MSYMBOL_TYPE (msymbol
))
4393 case mst_solib_trampoline
:
4396 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4399 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4401 bv
= BLOCKVECTOR (s
);
4402 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4403 ada_add_block_symbols (&symbol_list_obstack
, block
,
4404 SYMBOL_LINKAGE_NAME (msymbol
),
4405 namespace, objfile
, s
, wild_match
);
4407 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4409 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4410 ada_add_block_symbols (&symbol_list_obstack
, block
,
4411 SYMBOL_LINKAGE_NAME (msymbol
),
4412 namespace, objfile
, s
,
4421 ALL_PSYMTABS (objfile
, ps
)
4425 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4427 s
= PSYMTAB_TO_SYMTAB (ps
);
4430 bv
= BLOCKVECTOR (s
);
4431 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4432 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4433 namespace, objfile
, s
, wild_match
);
4437 /* Now add symbols from all per-file blocks if we've gotten no hits
4438 (Not strictly correct, but perhaps better than an error).
4439 Do the symtabs first, then check the psymtabs. */
4441 if (num_defns_collected (&symbol_list_obstack
) == 0)
4444 ALL_SYMTABS (objfile
, s
)
4449 bv
= BLOCKVECTOR (s
);
4450 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4451 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4452 objfile
, s
, wild_match
);
4455 ALL_PSYMTABS (objfile
, ps
)
4459 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4461 s
= PSYMTAB_TO_SYMTAB (ps
);
4462 bv
= BLOCKVECTOR (s
);
4465 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4466 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4467 namespace, objfile
, s
, wild_match
);
4473 ndefns
= num_defns_collected (&symbol_list_obstack
);
4474 *results
= defns_collected (&symbol_list_obstack
, 1);
4476 ndefns
= remove_extra_symbols (*results
, ndefns
);
4479 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4481 if (ndefns
== 1 && cacheIfUnique
)
4482 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4483 (*results
)[0].symtab
);
4485 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4486 (struct block
*) block0
);
4491 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4492 scope and in global scopes, or NULL if none. NAME is folded and
4493 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4494 choosing the first symbol if there are multiple choices.
4495 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4496 table in which the symbol was found (in both cases, these
4497 assignments occur only if the pointers are non-null). */
4500 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4501 domain_enum
namespace, int *is_a_field_of_this
,
4502 struct symtab
**symtab
)
4504 struct ada_symbol_info
*candidates
;
4507 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4508 block0
, namespace, &candidates
);
4510 if (n_candidates
== 0)
4513 if (is_a_field_of_this
!= NULL
)
4514 *is_a_field_of_this
= 0;
4518 *symtab
= candidates
[0].symtab
;
4519 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4521 struct objfile
*objfile
;
4524 struct blockvector
*bv
;
4526 /* Search the list of symtabs for one which contains the
4527 address of the start of this block. */
4528 ALL_SYMTABS (objfile
, s
)
4530 bv
= BLOCKVECTOR (s
);
4531 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4532 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4533 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4536 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4538 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4542 return candidates
[0].sym
;
4545 static struct symbol
*
4546 ada_lookup_symbol_nonlocal (const char *name
,
4547 const char *linkage_name
,
4548 const struct block
*block
,
4549 const domain_enum domain
, struct symtab
**symtab
)
4551 if (linkage_name
== NULL
)
4552 linkage_name
= name
;
4553 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4558 /* True iff STR is a possible encoded suffix of a normal Ada name
4559 that is to be ignored for matching purposes. Suffixes of parallel
4560 names (e.g., XVE) are not included here. Currently, the possible suffixes
4561 are given by either of the regular expression:
4563 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4565 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4566 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4570 is_name_suffix (const char *str
)
4573 const char *matching
;
4574 const int len
= strlen (str
);
4576 /* (__[0-9]+)?\.[0-9]+ */
4578 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4581 while (isdigit (matching
[0]))
4583 if (matching
[0] == '\0')
4587 if (matching
[0] == '.')
4590 while (isdigit (matching
[0]))
4592 if (matching
[0] == '\0')
4597 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4600 while (isdigit (matching
[0]))
4602 if (matching
[0] == '\0')
4606 /* ??? We should not modify STR directly, as we are doing below. This
4607 is fine in this case, but may become problematic later if we find
4608 that this alternative did not work, and want to try matching
4609 another one from the begining of STR. Since we modified it, we
4610 won't be able to find the begining of the string anymore! */
4614 while (str
[0] != '_' && str
[0] != '\0')
4616 if (str
[0] != 'n' && str
[0] != 'b')
4621 if (str
[0] == '\000')
4625 if (str
[1] != '_' || str
[2] == '\000')
4629 if (strcmp (str
+ 3, "JM") == 0)
4631 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4632 the LJM suffix in favor of the JM one. But we will
4633 still accept LJM as a valid suffix for a reasonable
4634 amount of time, just to allow ourselves to debug programs
4635 compiled using an older version of GNAT. */
4636 if (strcmp (str
+ 3, "LJM") == 0)
4640 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4641 || str
[4] == 'U' || str
[4] == 'P')
4643 if (str
[4] == 'R' && str
[5] != 'T')
4647 if (!isdigit (str
[2]))
4649 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4650 if (!isdigit (str
[k
]) && str
[k
] != '_')
4654 if (str
[0] == '$' && isdigit (str
[1]))
4656 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4657 if (!isdigit (str
[k
]) && str
[k
] != '_')
4664 /* Return nonzero if the given string starts with a dot ('.')
4665 followed by zero or more digits.
4667 Note: brobecker/2003-11-10: A forward declaration has not been
4668 added at the begining of this file yet, because this function
4669 is only used to work around a problem found during wild matching
4670 when trying to match minimal symbol names against symbol names
4671 obtained from dwarf-2 data. This function is therefore currently
4672 only used in wild_match() and is likely to be deleted when the
4673 problem in dwarf-2 is fixed. */
4676 is_dot_digits_suffix (const char *str
)
4682 while (isdigit (str
[0]))
4684 return (str
[0] == '\0');
4687 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4688 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4689 informational suffixes of NAME (i.e., for which is_name_suffix is
4693 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4699 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4700 stored in the symbol table for nested function names is sometimes
4701 different from the name of the associated entity stored in
4702 the dwarf-2 data: This is the case for nested subprograms, where
4703 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4704 while the symbol name from the dwarf-2 data does not.
4706 Although the DWARF-2 standard documents that entity names stored
4707 in the dwarf-2 data should be identical to the name as seen in
4708 the source code, GNAT takes a different approach as we already use
4709 a special encoding mechanism to convey the information so that
4710 a C debugger can still use the information generated to debug
4711 Ada programs. A corollary is that the symbol names in the dwarf-2
4712 data should match the names found in the symbol table. I therefore
4713 consider this issue as a compiler defect.
4715 Until the compiler is properly fixed, we work-around the problem
4716 by ignoring such suffixes during the match. We do so by making
4717 a copy of PATN0 and NAME0, and then by stripping such a suffix
4718 if present. We then perform the match on the resulting strings. */
4721 name_len
= strlen (name0
);
4723 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4724 strcpy (name
, name0
);
4725 dot
= strrchr (name
, '.');
4726 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4729 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4730 strncpy (patn
, patn0
, patn_len
);
4731 patn
[patn_len
] = '\0';
4732 dot
= strrchr (patn
, '.');
4733 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4736 patn_len
= dot
- patn
;
4740 /* Now perform the wild match. */
4742 name_len
= strlen (name
);
4743 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4744 && strncmp (patn
, name
+ 5, patn_len
) == 0
4745 && is_name_suffix (name
+ patn_len
+ 5))
4748 while (name_len
>= patn_len
)
4750 if (strncmp (patn
, name
, patn_len
) == 0
4751 && is_name_suffix (name
+ patn_len
))
4759 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4764 if (!islower (name
[2]))
4771 if (!islower (name
[1]))
4782 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4783 vector *defn_symbols, updating the list of symbols in OBSTACKP
4784 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4785 OBJFILE is the section containing BLOCK.
4786 SYMTAB is recorded with each symbol added. */
4789 ada_add_block_symbols (struct obstack
*obstackp
,
4790 struct block
*block
, const char *name
,
4791 domain_enum domain
, struct objfile
*objfile
,
4792 struct symtab
*symtab
, int wild
)
4794 struct dict_iterator iter
;
4795 int name_len
= strlen (name
);
4796 /* A matching argument symbol, if any. */
4797 struct symbol
*arg_sym
;
4798 /* Set true when we find a matching non-argument symbol. */
4807 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4809 if (SYMBOL_DOMAIN (sym
) == domain
4810 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
4812 switch (SYMBOL_CLASS (sym
))
4818 case LOC_REGPARM_ADDR
:
4819 case LOC_BASEREG_ARG
:
4820 case LOC_COMPUTED_ARG
:
4823 case LOC_UNRESOLVED
:
4827 add_defn_to_vec (obstackp
,
4828 fixup_symbol_section (sym
, objfile
),
4837 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4839 if (SYMBOL_DOMAIN (sym
) == domain
)
4841 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
4843 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
4845 switch (SYMBOL_CLASS (sym
))
4851 case LOC_REGPARM_ADDR
:
4852 case LOC_BASEREG_ARG
:
4853 case LOC_COMPUTED_ARG
:
4856 case LOC_UNRESOLVED
:
4860 add_defn_to_vec (obstackp
,
4861 fixup_symbol_section (sym
, objfile
),
4870 if (!found_sym
&& arg_sym
!= NULL
)
4872 add_defn_to_vec (obstackp
,
4873 fixup_symbol_section (arg_sym
, objfile
),
4882 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4884 if (SYMBOL_DOMAIN (sym
) == domain
)
4888 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
4891 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
4893 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
4898 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
4900 switch (SYMBOL_CLASS (sym
))
4906 case LOC_REGPARM_ADDR
:
4907 case LOC_BASEREG_ARG
:
4908 case LOC_COMPUTED_ARG
:
4911 case LOC_UNRESOLVED
:
4915 add_defn_to_vec (obstackp
,
4916 fixup_symbol_section (sym
, objfile
),
4924 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4925 They aren't parameters, right? */
4926 if (!found_sym
&& arg_sym
!= NULL
)
4928 add_defn_to_vec (obstackp
,
4929 fixup_symbol_section (arg_sym
, objfile
),
4937 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
4938 to be invisible to users. */
4941 ada_is_ignored_field (struct type
*type
, int field_num
)
4943 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
4947 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
4948 return (name
== NULL
4949 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
4953 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
4954 pointer or reference type whose ultimate target has a tag field. */
4957 ada_is_tagged_type (struct type
*type
, int refok
)
4959 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
4962 /* True iff TYPE represents the type of X'Tag */
4965 ada_is_tag_type (struct type
*type
)
4967 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
4971 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
4972 return (name
!= NULL
4973 && strcmp (name
, "ada__tags__dispatch_table") == 0);
4977 /* The type of the tag on VAL. */
4980 ada_tag_type (struct value
*val
)
4982 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
4985 /* The value of the tag on VAL. */
4988 ada_value_tag (struct value
*val
)
4990 return ada_value_struct_elt (val
, "_tag", "record");
4993 /* The value of the tag on the object of type TYPE whose contents are
4994 saved at VALADDR, if it is non-null, or is at memory address
4997 static struct value
*
4998 value_tag_from_contents_and_address (struct type
*type
, char *valaddr
,
5001 int tag_byte_offset
, dummy1
, dummy2
;
5002 struct type
*tag_type
;
5003 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5006 char *valaddr1
= (valaddr
== NULL
) ? NULL
: valaddr
+ tag_byte_offset
;
5007 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5009 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5014 static struct type
*
5015 type_from_tag (struct value
*tag
)
5017 const char *type_name
= ada_tag_name (tag
);
5018 if (type_name
!= NULL
)
5019 return ada_find_any_type (ada_encode (type_name
));
5029 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5030 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5031 The value stored in ARGS->name is valid until the next call to
5035 ada_tag_name_1 (void *args0
)
5037 struct tag_args
*args
= (struct tag_args
*) args0
;
5038 static char name
[1024];
5042 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
5045 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
5048 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5049 for (p
= name
; *p
!= '\0'; p
+= 1)
5056 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5060 ada_tag_name (struct value
*tag
)
5062 struct tag_args args
;
5063 if (!ada_is_tag_type (value_type (tag
)))
5067 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5071 /* The parent type of TYPE, or NULL if none. */
5074 ada_parent_type (struct type
*type
)
5078 type
= ada_check_typedef (type
);
5080 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5083 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5084 if (ada_is_parent_field (type
, i
))
5085 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5090 /* True iff field number FIELD_NUM of structure type TYPE contains the
5091 parent-type (inherited) fields of a derived type. Assumes TYPE is
5092 a structure type with at least FIELD_NUM+1 fields. */
5095 ada_is_parent_field (struct type
*type
, int field_num
)
5097 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5098 return (name
!= NULL
5099 && (strncmp (name
, "PARENT", 6) == 0
5100 || strncmp (name
, "_parent", 7) == 0));
5103 /* True iff field number FIELD_NUM of structure type TYPE is a
5104 transparent wrapper field (which should be silently traversed when doing
5105 field selection and flattened when printing). Assumes TYPE is a
5106 structure type with at least FIELD_NUM+1 fields. Such fields are always
5110 ada_is_wrapper_field (struct type
*type
, int field_num
)
5112 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5113 return (name
!= NULL
5114 && (strncmp (name
, "PARENT", 6) == 0
5115 || strcmp (name
, "REP") == 0
5116 || strncmp (name
, "_parent", 7) == 0
5117 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5120 /* True iff field number FIELD_NUM of structure or union type TYPE
5121 is a variant wrapper. Assumes TYPE is a structure type with at least
5122 FIELD_NUM+1 fields. */
5125 ada_is_variant_part (struct type
*type
, int field_num
)
5127 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5128 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5129 || (is_dynamic_field (type
, field_num
)
5130 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5131 == TYPE_CODE_UNION
)));
5134 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5135 whose discriminants are contained in the record type OUTER_TYPE,
5136 returns the type of the controlling discriminant for the variant. */
5139 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5141 char *name
= ada_variant_discrim_name (var_type
);
5143 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5145 return builtin_type_int
;
5150 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5151 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5152 represents a 'when others' clause; otherwise 0. */
5155 ada_is_others_clause (struct type
*type
, int field_num
)
5157 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5158 return (name
!= NULL
&& name
[0] == 'O');
5161 /* Assuming that TYPE0 is the type of the variant part of a record,
5162 returns the name of the discriminant controlling the variant.
5163 The value is valid until the next call to ada_variant_discrim_name. */
5166 ada_variant_discrim_name (struct type
*type0
)
5168 static char *result
= NULL
;
5169 static size_t result_len
= 0;
5172 const char *discrim_end
;
5173 const char *discrim_start
;
5175 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5176 type
= TYPE_TARGET_TYPE (type0
);
5180 name
= ada_type_name (type
);
5182 if (name
== NULL
|| name
[0] == '\000')
5185 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5188 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5191 if (discrim_end
== name
)
5194 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5197 if (discrim_start
== name
+ 1)
5199 if ((discrim_start
> name
+ 3
5200 && strncmp (discrim_start
- 3, "___", 3) == 0)
5201 || discrim_start
[-1] == '.')
5205 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5206 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5207 result
[discrim_end
- discrim_start
] = '\0';
5211 /* Scan STR for a subtype-encoded number, beginning at position K.
5212 Put the position of the character just past the number scanned in
5213 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5214 Return 1 if there was a valid number at the given position, and 0
5215 otherwise. A "subtype-encoded" number consists of the absolute value
5216 in decimal, followed by the letter 'm' to indicate a negative number.
5217 Assumes 0m does not occur. */
5220 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5224 if (!isdigit (str
[k
]))
5227 /* Do it the hard way so as not to make any assumption about
5228 the relationship of unsigned long (%lu scan format code) and
5231 while (isdigit (str
[k
]))
5233 RU
= RU
* 10 + (str
[k
] - '0');
5240 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5246 /* NOTE on the above: Technically, C does not say what the results of
5247 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5248 number representable as a LONGEST (although either would probably work
5249 in most implementations). When RU>0, the locution in the then branch
5250 above is always equivalent to the negative of RU. */
5257 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5258 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5259 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5262 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5264 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5277 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5286 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5287 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5289 if (val
>= L
&& val
<= U
)
5301 /* FIXME: Lots of redundancy below. Try to consolidate. */
5303 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5304 ARG_TYPE, extract and return the value of one of its (non-static)
5305 fields. FIELDNO says which field. Differs from value_primitive_field
5306 only in that it can handle packed values of arbitrary type. */
5308 static struct value
*
5309 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5310 struct type
*arg_type
)
5314 arg_type
= ada_check_typedef (arg_type
);
5315 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5317 /* Handle packed fields. */
5319 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5321 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5322 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5324 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5325 offset
+ bit_pos
/ 8,
5326 bit_pos
% 8, bit_size
, type
);
5329 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5332 /* Find field with name NAME in object of type TYPE. If found, return 1
5333 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
5334 OFFSET + the byte offset of the field within an object of that type,
5335 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
5336 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
5337 Looks inside wrappers for the field. Returns 0 if field not
5340 find_struct_field (char *name
, struct type
*type
, int offset
,
5341 struct type
**field_type_p
,
5342 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
5346 type
= ada_check_typedef (type
);
5347 *field_type_p
= NULL
;
5348 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
5350 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5352 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
5353 int fld_offset
= offset
+ bit_pos
/ 8;
5354 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5356 if (t_field_name
== NULL
)
5359 else if (field_name_match (t_field_name
, name
))
5361 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
5362 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
5363 *byte_offset_p
= fld_offset
;
5364 *bit_offset_p
= bit_pos
% 8;
5365 *bit_size_p
= bit_size
;
5368 else if (ada_is_wrapper_field (type
, i
))
5370 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
5371 field_type_p
, byte_offset_p
, bit_offset_p
,
5375 else if (ada_is_variant_part (type
, i
))
5378 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5380 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5382 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
5384 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5385 field_type_p
, byte_offset_p
,
5386 bit_offset_p
, bit_size_p
))
5396 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5397 and search in it assuming it has (class) type TYPE.
5398 If found, return value, else return NULL.
5400 Searches recursively through wrapper fields (e.g., '_parent'). */
5402 static struct value
*
5403 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5407 type
= ada_check_typedef (type
);
5409 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5411 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5413 if (t_field_name
== NULL
)
5416 else if (field_name_match (t_field_name
, name
))
5417 return ada_value_primitive_field (arg
, offset
, i
, type
);
5419 else if (ada_is_wrapper_field (type
, i
))
5421 struct value
*v
= /* Do not let indent join lines here. */
5422 ada_search_struct_field (name
, arg
,
5423 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5424 TYPE_FIELD_TYPE (type
, i
));
5429 else if (ada_is_variant_part (type
, i
))
5432 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5433 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5435 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5437 struct value
*v
= ada_search_struct_field
/* Force line break. */
5439 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5440 TYPE_FIELD_TYPE (field_type
, j
));
5449 /* Given ARG, a value of type (pointer or reference to a)*
5450 structure/union, extract the component named NAME from the ultimate
5451 target structure/union and return it as a value with its
5452 appropriate type. If ARG is a pointer or reference and the field
5453 is not packed, returns a reference to the field, otherwise the
5454 value of the field (an lvalue if ARG is an lvalue).
5456 The routine searches for NAME among all members of the structure itself
5457 and (recursively) among all members of any wrapper members
5460 ERR is a name (for use in error messages) that identifies the class
5461 of entity that ARG is supposed to be. ERR may be null, indicating
5462 that on error, the function simply returns NULL, and does not
5463 throw an error. (FIXME: True only if ARG is a pointer or reference
5467 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5469 struct type
*t
, *t1
;
5473 t1
= t
= ada_check_typedef (value_type (arg
));
5474 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5476 t1
= TYPE_TARGET_TYPE (t
);
5482 error (_("Bad value type in a %s."), err
);
5484 t1
= ada_check_typedef (t1
);
5485 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5487 arg
= coerce_ref (arg
);
5492 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5494 t1
= TYPE_TARGET_TYPE (t
);
5500 error (_("Bad value type in a %s."), err
);
5502 t1
= ada_check_typedef (t1
);
5503 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5505 arg
= value_ind (arg
);
5512 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
5517 error (_("Attempt to extract a component of a value that is not a %s."),
5522 v
= ada_search_struct_field (name
, arg
, 0, t
);
5525 int bit_offset
, bit_size
, byte_offset
;
5526 struct type
*field_type
;
5529 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5530 address
= value_as_address (arg
);
5532 address
= unpack_pointer (t
, VALUE_CONTENTS (arg
));
5534 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
5535 if (find_struct_field (name
, t1
, 0,
5536 &field_type
, &byte_offset
, &bit_offset
,
5541 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5542 arg
= ada_coerce_ref (arg
);
5544 arg
= ada_value_ind (arg
);
5545 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
5546 bit_offset
, bit_size
,
5550 v
= value_from_pointer (lookup_reference_type (field_type
),
5551 address
+ byte_offset
);
5555 if (v
== NULL
&& err
!= NULL
)
5556 error (_("There is no member named %s."), name
);
5561 /* Given a type TYPE, look up the type of the component of type named NAME.
5562 If DISPP is non-null, add its byte displacement from the beginning of a
5563 structure (pointed to by a value) of type TYPE to *DISPP (does not
5564 work for packed fields).
5566 Matches any field whose name has NAME as a prefix, possibly
5569 TYPE can be either a struct or union. If REFOK, TYPE may also
5570 be a (pointer or reference)+ to a struct or union, and the
5571 ultimate target type will be searched.
5573 Looks recursively into variant clauses and parent types.
5575 If NOERR is nonzero, return NULL if NAME is not suitably defined or
5576 TYPE is not a type of the right kind. */
5578 static struct type
*
5579 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
5580 int noerr
, int *dispp
)
5587 if (refok
&& type
!= NULL
)
5590 type
= ada_check_typedef (type
);
5591 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5592 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5594 type
= TYPE_TARGET_TYPE (type
);
5598 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
5599 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
5605 target_terminal_ours ();
5606 gdb_flush (gdb_stdout
);
5608 error (_("Type (null) is not a structure or union type"));
5611 /* XXX: type_sprint */
5612 fprintf_unfiltered (gdb_stderr
, _("Type "));
5613 type_print (type
, "", gdb_stderr
, -1);
5614 error (_(" is not a structure or union type"));
5619 type
= to_static_fixed_type (type
);
5621 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5623 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5627 if (t_field_name
== NULL
)
5630 else if (field_name_match (t_field_name
, name
))
5633 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5634 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5637 else if (ada_is_wrapper_field (type
, i
))
5640 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5645 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5650 else if (ada_is_variant_part (type
, i
))
5653 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5655 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5658 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5663 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5674 target_terminal_ours ();
5675 gdb_flush (gdb_stdout
);
5678 /* XXX: type_sprint */
5679 fprintf_unfiltered (gdb_stderr
, _("Type "));
5680 type_print (type
, "", gdb_stderr
, -1);
5681 error (_(" has no component named <null>"));
5685 /* XXX: type_sprint */
5686 fprintf_unfiltered (gdb_stderr
, _("Type "));
5687 type_print (type
, "", gdb_stderr
, -1);
5688 error (_(" has no component named %s"), name
);
5695 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5696 within a value of type OUTER_TYPE that is stored in GDB at
5697 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5698 numbering from 0) is applicable. Returns -1 if none are. */
5701 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5702 char *outer_valaddr
)
5707 struct type
*discrim_type
;
5708 char *discrim_name
= ada_variant_discrim_name (var_type
);
5709 LONGEST discrim_val
;
5713 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
5714 if (discrim_type
== NULL
)
5716 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5719 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5721 if (ada_is_others_clause (var_type
, i
))
5723 else if (ada_in_variant (discrim_val
, var_type
, i
))
5727 return others_clause
;
5732 /* Dynamic-Sized Records */
5734 /* Strategy: The type ostensibly attached to a value with dynamic size
5735 (i.e., a size that is not statically recorded in the debugging
5736 data) does not accurately reflect the size or layout of the value.
5737 Our strategy is to convert these values to values with accurate,
5738 conventional types that are constructed on the fly. */
5740 /* There is a subtle and tricky problem here. In general, we cannot
5741 determine the size of dynamic records without its data. However,
5742 the 'struct value' data structure, which GDB uses to represent
5743 quantities in the inferior process (the target), requires the size
5744 of the type at the time of its allocation in order to reserve space
5745 for GDB's internal copy of the data. That's why the
5746 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5747 rather than struct value*s.
5749 However, GDB's internal history variables ($1, $2, etc.) are
5750 struct value*s containing internal copies of the data that are not, in
5751 general, the same as the data at their corresponding addresses in
5752 the target. Fortunately, the types we give to these values are all
5753 conventional, fixed-size types (as per the strategy described
5754 above), so that we don't usually have to perform the
5755 'to_fixed_xxx_type' conversions to look at their values.
5756 Unfortunately, there is one exception: if one of the internal
5757 history variables is an array whose elements are unconstrained
5758 records, then we will need to create distinct fixed types for each
5759 element selected. */
5761 /* The upshot of all of this is that many routines take a (type, host
5762 address, target address) triple as arguments to represent a value.
5763 The host address, if non-null, is supposed to contain an internal
5764 copy of the relevant data; otherwise, the program is to consult the
5765 target at the target address. */
5767 /* Assuming that VAL0 represents a pointer value, the result of
5768 dereferencing it. Differs from value_ind in its treatment of
5769 dynamic-sized types. */
5772 ada_value_ind (struct value
*val0
)
5774 struct value
*val
= unwrap_value (value_ind (val0
));
5775 return ada_to_fixed_value (val
);
5778 /* The value resulting from dereferencing any "reference to"
5779 qualifiers on VAL0. */
5781 static struct value
*
5782 ada_coerce_ref (struct value
*val0
)
5784 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
5786 struct value
*val
= val0
;
5787 val
= coerce_ref (val
);
5788 val
= unwrap_value (val
);
5789 return ada_to_fixed_value (val
);
5795 /* Return OFF rounded upward if necessary to a multiple of
5796 ALIGNMENT (a power of 2). */
5799 align_value (unsigned int off
, unsigned int alignment
)
5801 return (off
+ alignment
- 1) & ~(alignment
- 1);
5804 /* Return the bit alignment required for field #F of template type TYPE. */
5807 field_alignment (struct type
*type
, int f
)
5809 const char *name
= TYPE_FIELD_NAME (type
, f
);
5810 int len
= (name
== NULL
) ? 0 : strlen (name
);
5813 if (!isdigit (name
[len
- 1]))
5816 if (isdigit (name
[len
- 2]))
5817 align_offset
= len
- 2;
5819 align_offset
= len
- 1;
5821 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
5822 return TARGET_CHAR_BIT
;
5824 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5827 /* Find a symbol named NAME. Ignores ambiguity. */
5830 ada_find_any_symbol (const char *name
)
5834 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
5835 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5838 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
5842 /* Find a type named NAME. Ignores ambiguity. */
5845 ada_find_any_type (const char *name
)
5847 struct symbol
*sym
= ada_find_any_symbol (name
);
5850 return SYMBOL_TYPE (sym
);
5855 /* Given a symbol NAME and its associated BLOCK, search all symbols
5856 for its ___XR counterpart, which is the ``renaming'' symbol
5857 associated to NAME. Return this symbol if found, return
5861 ada_find_renaming_symbol (const char *name
, struct block
*block
)
5863 const struct symbol
*function_sym
= block_function (block
);
5866 if (function_sym
!= NULL
)
5868 /* If the symbol is defined inside a function, NAME is not fully
5869 qualified. This means we need to prepend the function name
5870 as well as adding the ``___XR'' suffix to build the name of
5871 the associated renaming symbol. */
5872 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
5873 const int function_name_len
= strlen (function_name
);
5874 const int rename_len
= function_name_len
+ 2 /* "__" */
5875 + strlen (name
) + 6 /* "___XR\0" */ ;
5877 /* Library-level functions are a special case, as GNAT adds
5878 a ``_ada_'' prefix to the function name to avoid namespace
5879 pollution. However, the renaming symbol themselves do not
5880 have this prefix, so we need to skip this prefix if present. */
5881 if (function_name_len
> 5 /* "_ada_" */
5882 && strstr (function_name
, "_ada_") == function_name
)
5883 function_name
= function_name
+ 5;
5885 rename
= (char *) alloca (rename_len
* sizeof (char));
5886 sprintf (rename
, "%s__%s___XR", function_name
, name
);
5890 const int rename_len
= strlen (name
) + 6;
5891 rename
= (char *) alloca (rename_len
* sizeof (char));
5892 sprintf (rename
, "%s___XR", name
);
5895 return ada_find_any_symbol (rename
);
5898 /* Because of GNAT encoding conventions, several GDB symbols may match a
5899 given type name. If the type denoted by TYPE0 is to be preferred to
5900 that of TYPE1 for purposes of type printing, return non-zero;
5901 otherwise return 0. */
5904 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5908 else if (type0
== NULL
)
5910 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5912 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5914 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
5916 else if (ada_is_packed_array_type (type0
))
5918 else if (ada_is_array_descriptor_type (type0
)
5919 && !ada_is_array_descriptor_type (type1
))
5921 else if (ada_renaming_type (type0
) != NULL
5922 && ada_renaming_type (type1
) == NULL
)
5927 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5928 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5931 ada_type_name (struct type
*type
)
5935 else if (TYPE_NAME (type
) != NULL
)
5936 return TYPE_NAME (type
);
5938 return TYPE_TAG_NAME (type
);
5941 /* Find a parallel type to TYPE whose name is formed by appending
5942 SUFFIX to the name of TYPE. */
5945 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5948 static size_t name_len
= 0;
5950 char *typename
= ada_type_name (type
);
5952 if (typename
== NULL
)
5955 len
= strlen (typename
);
5957 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5959 strcpy (name
, typename
);
5960 strcpy (name
+ len
, suffix
);
5962 return ada_find_any_type (name
);
5966 /* If TYPE is a variable-size record type, return the corresponding template
5967 type describing its fields. Otherwise, return NULL. */
5969 static struct type
*
5970 dynamic_template_type (struct type
*type
)
5972 type
= ada_check_typedef (type
);
5974 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5975 || ada_type_name (type
) == NULL
)
5979 int len
= strlen (ada_type_name (type
));
5980 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
5983 return ada_find_parallel_type (type
, "___XVE");
5987 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5988 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5991 is_dynamic_field (struct type
*templ_type
, int field_num
)
5993 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5995 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5996 && strstr (name
, "___XVL") != NULL
;
5999 /* The index of the variant field of TYPE, or -1 if TYPE does not
6000 represent a variant record type. */
6003 variant_field_index (struct type
*type
)
6007 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6010 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6012 if (ada_is_variant_part (type
, f
))
6018 /* A record type with no fields. */
6020 static struct type
*
6021 empty_record (struct objfile
*objfile
)
6023 struct type
*type
= alloc_type (objfile
);
6024 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6025 TYPE_NFIELDS (type
) = 0;
6026 TYPE_FIELDS (type
) = NULL
;
6027 TYPE_NAME (type
) = "<empty>";
6028 TYPE_TAG_NAME (type
) = NULL
;
6029 TYPE_FLAGS (type
) = 0;
6030 TYPE_LENGTH (type
) = 0;
6034 /* An ordinary record type (with fixed-length fields) that describes
6035 the value of type TYPE at VALADDR or ADDRESS (see comments at
6036 the beginning of this section) VAL according to GNAT conventions.
6037 DVAL0 should describe the (portion of a) record that contains any
6038 necessary discriminants. It should be NULL if value_type (VAL) is
6039 an outer-level type (i.e., as opposed to a branch of a variant.) A
6040 variant field (unless unchecked) is replaced by a particular branch
6043 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6044 length are not statically known are discarded. As a consequence,
6045 VALADDR, ADDRESS and DVAL0 are ignored.
6047 NOTE: Limitations: For now, we assume that dynamic fields and
6048 variants occupy whole numbers of bytes. However, they need not be
6052 ada_template_to_fixed_record_type_1 (struct type
*type
, char *valaddr
,
6053 CORE_ADDR address
, struct value
*dval0
,
6054 int keep_dynamic_fields
)
6056 struct value
*mark
= value_mark ();
6059 int nfields
, bit_len
;
6062 int fld_bit_len
, bit_incr
;
6065 /* Compute the number of fields in this record type that are going
6066 to be processed: unless keep_dynamic_fields, this includes only
6067 fields whose position and length are static will be processed. */
6068 if (keep_dynamic_fields
)
6069 nfields
= TYPE_NFIELDS (type
);
6073 while (nfields
< TYPE_NFIELDS (type
)
6074 && !ada_is_variant_part (type
, nfields
)
6075 && !is_dynamic_field (type
, nfields
))
6079 rtype
= alloc_type (TYPE_OBJFILE (type
));
6080 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6081 INIT_CPLUS_SPECIFIC (rtype
);
6082 TYPE_NFIELDS (rtype
) = nfields
;
6083 TYPE_FIELDS (rtype
) = (struct field
*)
6084 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6085 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6086 TYPE_NAME (rtype
) = ada_type_name (type
);
6087 TYPE_TAG_NAME (rtype
) = NULL
;
6088 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6094 for (f
= 0; f
< nfields
; f
+= 1)
6096 off
= align_value (off
, field_alignment (type
, f
))
6097 + TYPE_FIELD_BITPOS (type
, f
);
6098 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6099 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6101 if (ada_is_variant_part (type
, f
))
6104 fld_bit_len
= bit_incr
= 0;
6106 else if (is_dynamic_field (type
, f
))
6109 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6113 TYPE_FIELD_TYPE (rtype
, f
) =
6116 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6117 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6118 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6119 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6120 bit_incr
= fld_bit_len
=
6121 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6125 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6126 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6127 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6128 bit_incr
= fld_bit_len
=
6129 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6131 bit_incr
= fld_bit_len
=
6132 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6134 if (off
+ fld_bit_len
> bit_len
)
6135 bit_len
= off
+ fld_bit_len
;
6137 TYPE_LENGTH (rtype
) =
6138 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6141 /* We handle the variant part, if any, at the end because of certain
6142 odd cases in which it is re-ordered so as NOT the last field of
6143 the record. This can happen in the presence of representation
6145 if (variant_field
>= 0)
6147 struct type
*branch_type
;
6149 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6152 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6157 to_fixed_variant_branch_type
6158 (TYPE_FIELD_TYPE (type
, variant_field
),
6159 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6160 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6161 if (branch_type
== NULL
)
6163 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6164 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6165 TYPE_NFIELDS (rtype
) -= 1;
6169 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6170 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6172 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6174 if (off
+ fld_bit_len
> bit_len
)
6175 bit_len
= off
+ fld_bit_len
;
6176 TYPE_LENGTH (rtype
) =
6177 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6181 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6182 should contain the alignment of that record, which should be a strictly
6183 positive value. If null or negative, then something is wrong, most
6184 probably in the debug info. In that case, we don't round up the size
6185 of the resulting type. If this record is not part of another structure,
6186 the current RTYPE length might be good enough for our purposes. */
6187 if (TYPE_LENGTH (type
) <= 0)
6189 if (TYPE_NAME (rtype
))
6190 warning (_("Invalid type size for `%s' detected: %d."),
6191 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6193 warning (_("Invalid type size for <unnamed> detected: %d."),
6194 TYPE_LENGTH (type
));
6198 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6199 TYPE_LENGTH (type
));
6202 value_free_to_mark (mark
);
6203 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6204 error (_("record type with dynamic size is larger than varsize-limit"));
6208 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6211 static struct type
*
6212 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6213 CORE_ADDR address
, struct value
*dval0
)
6215 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6219 /* An ordinary record type in which ___XVL-convention fields and
6220 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6221 static approximations, containing all possible fields. Uses
6222 no runtime values. Useless for use in values, but that's OK,
6223 since the results are used only for type determinations. Works on both
6224 structs and unions. Representation note: to save space, we memorize
6225 the result of this function in the TYPE_TARGET_TYPE of the
6228 static struct type
*
6229 template_to_static_fixed_type (struct type
*type0
)
6235 if (TYPE_TARGET_TYPE (type0
) != NULL
)
6236 return TYPE_TARGET_TYPE (type0
);
6238 nfields
= TYPE_NFIELDS (type0
);
6241 for (f
= 0; f
< nfields
; f
+= 1)
6243 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
6244 struct type
*new_type
;
6246 if (is_dynamic_field (type0
, f
))
6247 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
6249 new_type
= to_static_fixed_type (field_type
);
6250 if (type
== type0
&& new_type
!= field_type
)
6252 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
6253 TYPE_CODE (type
) = TYPE_CODE (type0
);
6254 INIT_CPLUS_SPECIFIC (type
);
6255 TYPE_NFIELDS (type
) = nfields
;
6256 TYPE_FIELDS (type
) = (struct field
*)
6257 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6258 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
6259 sizeof (struct field
) * nfields
);
6260 TYPE_NAME (type
) = ada_type_name (type0
);
6261 TYPE_TAG_NAME (type
) = NULL
;
6262 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
6263 TYPE_LENGTH (type
) = 0;
6265 TYPE_FIELD_TYPE (type
, f
) = new_type
;
6266 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
6271 /* Given an object of type TYPE whose contents are at VALADDR and
6272 whose address in memory is ADDRESS, returns a revision of TYPE --
6273 a non-dynamic-sized record with a variant part -- in which
6274 the variant part is replaced with the appropriate branch. Looks
6275 for discriminant values in DVAL0, which can be NULL if the record
6276 contains the necessary discriminant values. */
6278 static struct type
*
6279 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6280 CORE_ADDR address
, struct value
*dval0
)
6282 struct value
*mark
= value_mark ();
6285 struct type
*branch_type
;
6286 int nfields
= TYPE_NFIELDS (type
);
6287 int variant_field
= variant_field_index (type
);
6289 if (variant_field
== -1)
6293 dval
= value_from_contents_and_address (type
, valaddr
, address
);
6297 rtype
= alloc_type (TYPE_OBJFILE (type
));
6298 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6299 INIT_CPLUS_SPECIFIC (rtype
);
6300 TYPE_NFIELDS (rtype
) = nfields
;
6301 TYPE_FIELDS (rtype
) =
6302 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6303 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6304 sizeof (struct field
) * nfields
);
6305 TYPE_NAME (rtype
) = ada_type_name (type
);
6306 TYPE_TAG_NAME (rtype
) = NULL
;
6307 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6308 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6310 branch_type
= to_fixed_variant_branch_type
6311 (TYPE_FIELD_TYPE (type
, variant_field
),
6312 cond_offset_host (valaddr
,
6313 TYPE_FIELD_BITPOS (type
, variant_field
)
6315 cond_offset_target (address
,
6316 TYPE_FIELD_BITPOS (type
, variant_field
)
6317 / TARGET_CHAR_BIT
), dval
);
6318 if (branch_type
== NULL
)
6321 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
6322 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6323 TYPE_NFIELDS (rtype
) -= 1;
6327 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6328 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6329 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
6330 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6332 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
6334 value_free_to_mark (mark
);
6338 /* An ordinary record type (with fixed-length fields) that describes
6339 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6340 beginning of this section]. Any necessary discriminants' values
6341 should be in DVAL, a record value; it may be NULL if the object
6342 at ADDR itself contains any necessary discriminant values.
6343 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6344 values from the record are needed. Except in the case that DVAL,
6345 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6346 unchecked) is replaced by a particular branch of the variant.
6348 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6349 is questionable and may be removed. It can arise during the
6350 processing of an unconstrained-array-of-record type where all the
6351 variant branches have exactly the same size. This is because in
6352 such cases, the compiler does not bother to use the XVS convention
6353 when encoding the record. I am currently dubious of this
6354 shortcut and suspect the compiler should be altered. FIXME. */
6356 static struct type
*
6357 to_fixed_record_type (struct type
*type0
, char *valaddr
,
6358 CORE_ADDR address
, struct value
*dval
)
6360 struct type
*templ_type
;
6362 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6365 templ_type
= dynamic_template_type (type0
);
6367 if (templ_type
!= NULL
)
6368 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6369 else if (variant_field_index (type0
) >= 0)
6371 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
6373 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
6378 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
6384 /* An ordinary record type (with fixed-length fields) that describes
6385 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6386 union type. Any necessary discriminants' values should be in DVAL,
6387 a record value. That is, this routine selects the appropriate
6388 branch of the union at ADDR according to the discriminant value
6389 indicated in the union's type name. */
6391 static struct type
*
6392 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6393 CORE_ADDR address
, struct value
*dval
)
6396 struct type
*templ_type
;
6397 struct type
*var_type
;
6399 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6400 var_type
= TYPE_TARGET_TYPE (var_type0
);
6402 var_type
= var_type0
;
6404 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6406 if (templ_type
!= NULL
)
6407 var_type
= templ_type
;
6410 ada_which_variant_applies (var_type
,
6411 value_type (dval
), VALUE_CONTENTS (dval
));
6414 return empty_record (TYPE_OBJFILE (var_type
));
6415 else if (is_dynamic_field (var_type
, which
))
6416 return to_fixed_record_type
6417 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6418 valaddr
, address
, dval
);
6419 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
6421 to_fixed_record_type
6422 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6424 return TYPE_FIELD_TYPE (var_type
, which
);
6427 /* Assuming that TYPE0 is an array type describing the type of a value
6428 at ADDR, and that DVAL describes a record containing any
6429 discriminants used in TYPE0, returns a type for the value that
6430 contains no dynamic components (that is, no components whose sizes
6431 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6432 true, gives an error message if the resulting type's size is over
6435 static struct type
*
6436 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6439 struct type
*index_type_desc
;
6440 struct type
*result
;
6442 if (ada_is_packed_array_type (type0
) /* revisit? */
6443 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
6446 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6447 if (index_type_desc
== NULL
)
6449 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
6450 /* NOTE: elt_type---the fixed version of elt_type0---should never
6451 depend on the contents of the array in properly constructed
6453 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6455 if (elt_type0
== elt_type
)
6458 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6459 elt_type
, TYPE_INDEX_TYPE (type0
));
6464 struct type
*elt_type0
;
6467 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6468 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6470 /* NOTE: result---the fixed version of elt_type0---should never
6471 depend on the contents of the array in properly constructed
6473 result
= ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
);
6474 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6476 struct type
*range_type
=
6477 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6478 dval
, TYPE_OBJFILE (type0
));
6479 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6480 result
, range_type
);
6482 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6483 error (_("array type with dynamic size is larger than varsize-limit"));
6486 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
6491 /* A standard type (containing no dynamically sized components)
6492 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6493 DVAL describes a record containing any discriminants used in TYPE0,
6494 and may be NULL if there are none, or if the object of type TYPE at
6495 ADDRESS or in VALADDR contains these discriminants. */
6498 ada_to_fixed_type (struct type
*type
, char *valaddr
,
6499 CORE_ADDR address
, struct value
*dval
)
6501 type
= ada_check_typedef (type
);
6502 switch (TYPE_CODE (type
))
6506 case TYPE_CODE_STRUCT
:
6508 struct type
*static_type
= to_static_fixed_type (type
);
6509 if (ada_is_tagged_type (static_type
, 0))
6511 struct type
*real_type
=
6512 type_from_tag (value_tag_from_contents_and_address (static_type
,
6515 if (real_type
!= NULL
)
6518 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6520 case TYPE_CODE_ARRAY
:
6521 return to_fixed_array_type (type
, dval
, 1);
6522 case TYPE_CODE_UNION
:
6526 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6530 /* A standard (static-sized) type corresponding as well as possible to
6531 TYPE0, but based on no runtime data. */
6533 static struct type
*
6534 to_static_fixed_type (struct type
*type0
)
6541 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6544 type0
= ada_check_typedef (type0
);
6546 switch (TYPE_CODE (type0
))
6550 case TYPE_CODE_STRUCT
:
6551 type
= dynamic_template_type (type0
);
6553 return template_to_static_fixed_type (type
);
6555 return template_to_static_fixed_type (type0
);
6556 case TYPE_CODE_UNION
:
6557 type
= ada_find_parallel_type (type0
, "___XVU");
6559 return template_to_static_fixed_type (type
);
6561 return template_to_static_fixed_type (type0
);
6565 /* A static approximation of TYPE with all type wrappers removed. */
6567 static struct type
*
6568 static_unwrap_type (struct type
*type
)
6570 if (ada_is_aligner_type (type
))
6572 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
6573 if (ada_type_name (type1
) == NULL
)
6574 TYPE_NAME (type1
) = ada_type_name (type
);
6576 return static_unwrap_type (type1
);
6580 struct type
*raw_real_type
= ada_get_base_type (type
);
6581 if (raw_real_type
== type
)
6584 return to_static_fixed_type (raw_real_type
);
6588 /* In some cases, incomplete and private types require
6589 cross-references that are not resolved as records (for example,
6591 type FooP is access Foo;
6593 type Foo is array ...;
6594 ). In these cases, since there is no mechanism for producing
6595 cross-references to such types, we instead substitute for FooP a
6596 stub enumeration type that is nowhere resolved, and whose tag is
6597 the name of the actual type. Call these types "non-record stubs". */
6599 /* A type equivalent to TYPE that is not a non-record stub, if one
6600 exists, otherwise TYPE. */
6603 ada_check_typedef (struct type
*type
)
6605 CHECK_TYPEDEF (type
);
6606 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6607 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6608 || TYPE_TAG_NAME (type
) == NULL
)
6612 char *name
= TYPE_TAG_NAME (type
);
6613 struct type
*type1
= ada_find_any_type (name
);
6614 return (type1
== NULL
) ? type
: type1
;
6618 /* A value representing the data at VALADDR/ADDRESS as described by
6619 type TYPE0, but with a standard (static-sized) type that correctly
6620 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6621 type, then return VAL0 [this feature is simply to avoid redundant
6622 creation of struct values]. */
6624 static struct value
*
6625 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
6628 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
6629 if (type
== type0
&& val0
!= NULL
)
6632 return value_from_contents_and_address (type
, 0, address
);
6635 /* A value representing VAL, but with a standard (static-sized) type
6636 that correctly describes it. Does not necessarily create a new
6639 static struct value
*
6640 ada_to_fixed_value (struct value
*val
)
6642 return ada_to_fixed_value_create (value_type (val
),
6643 VALUE_ADDRESS (val
) + value_offset (val
),
6647 /* A value representing VAL, but with a standard (static-sized) type
6648 chosen to approximate the real type of VAL as well as possible, but
6649 without consulting any runtime values. For Ada dynamic-sized
6650 types, therefore, the type of the result is likely to be inaccurate. */
6653 ada_to_static_fixed_value (struct value
*val
)
6656 to_static_fixed_type (static_unwrap_type (value_type (val
)));
6657 if (type
== value_type (val
))
6660 return coerce_unspec_val_to_type (val
, type
);
6666 /* Table mapping attribute numbers to names.
6667 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
6669 static const char *attribute_names
[] = {
6687 ada_attribute_name (enum exp_opcode n
)
6689 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
6690 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
6692 return attribute_names
[0];
6695 /* Evaluate the 'POS attribute applied to ARG. */
6698 pos_atr (struct value
*arg
)
6700 struct type
*type
= value_type (arg
);
6702 if (!discrete_type_p (type
))
6703 error (_("'POS only defined on discrete types"));
6705 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6708 LONGEST v
= value_as_long (arg
);
6710 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6712 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6715 error (_("enumeration value is invalid: can't find 'POS"));
6718 return value_as_long (arg
);
6721 static struct value
*
6722 value_pos_atr (struct value
*arg
)
6724 return value_from_longest (builtin_type_int
, pos_atr (arg
));
6727 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6729 static struct value
*
6730 value_val_atr (struct type
*type
, struct value
*arg
)
6732 if (!discrete_type_p (type
))
6733 error (_("'VAL only defined on discrete types"));
6734 if (!integer_type_p (value_type (arg
)))
6735 error (_("'VAL requires integral argument"));
6737 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6739 long pos
= value_as_long (arg
);
6740 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6741 error (_("argument to 'VAL out of range"));
6742 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6745 return value_from_longest (type
, value_as_long (arg
));
6751 /* True if TYPE appears to be an Ada character type.
6752 [At the moment, this is true only for Character and Wide_Character;
6753 It is a heuristic test that could stand improvement]. */
6756 ada_is_character_type (struct type
*type
)
6758 const char *name
= ada_type_name (type
);
6761 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6762 || TYPE_CODE (type
) == TYPE_CODE_INT
6763 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6764 && (strcmp (name
, "character") == 0
6765 || strcmp (name
, "wide_character") == 0
6766 || strcmp (name
, "unsigned char") == 0);
6769 /* True if TYPE appears to be an Ada string type. */
6772 ada_is_string_type (struct type
*type
)
6774 type
= ada_check_typedef (type
);
6776 && TYPE_CODE (type
) != TYPE_CODE_PTR
6777 && (ada_is_simple_array_type (type
)
6778 || ada_is_array_descriptor_type (type
))
6779 && ada_array_arity (type
) == 1)
6781 struct type
*elttype
= ada_array_element_type (type
, 1);
6783 return ada_is_character_type (elttype
);
6790 /* True if TYPE is a struct type introduced by the compiler to force the
6791 alignment of a value. Such types have a single field with a
6792 distinctive name. */
6795 ada_is_aligner_type (struct type
*type
)
6797 type
= ada_check_typedef (type
);
6799 /* If we can find a parallel XVS type, then the XVS type should
6800 be used instead of this type. And hence, this is not an aligner
6802 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
6805 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6806 && TYPE_NFIELDS (type
) == 1
6807 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
6810 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6811 the parallel type. */
6814 ada_get_base_type (struct type
*raw_type
)
6816 struct type
*real_type_namer
;
6817 struct type
*raw_real_type
;
6819 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6822 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6823 if (real_type_namer
== NULL
6824 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6825 || TYPE_NFIELDS (real_type_namer
) != 1)
6828 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6829 if (raw_real_type
== NULL
)
6832 return raw_real_type
;
6835 /* The type of value designated by TYPE, with all aligners removed. */
6838 ada_aligned_type (struct type
*type
)
6840 if (ada_is_aligner_type (type
))
6841 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6843 return ada_get_base_type (type
);
6847 /* The address of the aligned value in an object at address VALADDR
6848 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6851 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6853 if (ada_is_aligner_type (type
))
6854 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6856 TYPE_FIELD_BITPOS (type
,
6857 0) / TARGET_CHAR_BIT
);
6864 /* The printed representation of an enumeration literal with encoded
6865 name NAME. The value is good to the next call of ada_enum_name. */
6867 ada_enum_name (const char *name
)
6869 static char *result
;
6870 static size_t result_len
= 0;
6873 /* First, unqualify the enumeration name:
6874 1. Search for the last '.' character. If we find one, then skip
6875 all the preceeding characters, the unqualified name starts
6876 right after that dot.
6877 2. Otherwise, we may be debugging on a target where the compiler
6878 translates dots into "__". Search forward for double underscores,
6879 but stop searching when we hit an overloading suffix, which is
6880 of the form "__" followed by digits. */
6882 tmp
= strrchr (name
, '.');
6887 while ((tmp
= strstr (name
, "__")) != NULL
)
6889 if (isdigit (tmp
[2]))
6899 if (name
[1] == 'U' || name
[1] == 'W')
6901 if (sscanf (name
+ 2, "%x", &v
) != 1)
6907 GROW_VECT (result
, result_len
, 16);
6908 if (isascii (v
) && isprint (v
))
6909 sprintf (result
, "'%c'", v
);
6910 else if (name
[1] == 'U')
6911 sprintf (result
, "[\"%02x\"]", v
);
6913 sprintf (result
, "[\"%04x\"]", v
);
6919 tmp
= strstr (name
, "__");
6921 tmp
= strstr (name
, "$");
6924 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
6925 strncpy (result
, name
, tmp
- name
);
6926 result
[tmp
- name
] = '\0';
6934 static struct value
*
6935 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6938 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6939 (expect_type
, exp
, pos
, noside
);
6942 /* Evaluate the subexpression of EXP starting at *POS as for
6943 evaluate_type, updating *POS to point just past the evaluated
6946 static struct value
*
6947 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6949 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6950 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6953 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6956 static struct value
*
6957 unwrap_value (struct value
*val
)
6959 struct type
*type
= ada_check_typedef (value_type (val
));
6960 if (ada_is_aligner_type (type
))
6962 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6963 NULL
, "internal structure");
6964 struct type
*val_type
= ada_check_typedef (value_type (v
));
6965 if (ada_type_name (val_type
) == NULL
)
6966 TYPE_NAME (val_type
) = ada_type_name (type
);
6968 return unwrap_value (v
);
6972 struct type
*raw_real_type
=
6973 ada_check_typedef (ada_get_base_type (type
));
6975 if (type
== raw_real_type
)
6979 coerce_unspec_val_to_type
6980 (val
, ada_to_fixed_type (raw_real_type
, 0,
6981 VALUE_ADDRESS (val
) + value_offset (val
),
6986 static struct value
*
6987 cast_to_fixed (struct type
*type
, struct value
*arg
)
6991 if (type
== value_type (arg
))
6993 else if (ada_is_fixed_point_type (value_type (arg
)))
6994 val
= ada_float_to_fixed (type
,
6995 ada_fixed_to_float (value_type (arg
),
6996 value_as_long (arg
)));
7000 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
7001 val
= ada_float_to_fixed (type
, argd
);
7004 return value_from_longest (type
, val
);
7007 static struct value
*
7008 cast_from_fixed_to_double (struct value
*arg
)
7010 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7011 value_as_long (arg
));
7012 return value_from_double (builtin_type_double
, val
);
7015 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7016 return the converted value. */
7018 static struct value
*
7019 coerce_for_assign (struct type
*type
, struct value
*val
)
7021 struct type
*type2
= value_type (val
);
7025 type2
= ada_check_typedef (type2
);
7026 type
= ada_check_typedef (type
);
7028 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7029 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7031 val
= ada_value_ind (val
);
7032 type2
= value_type (val
);
7035 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7036 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7038 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7039 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7040 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7041 error (_("Incompatible types in assignment"));
7047 static struct value
*
7048 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7051 struct type
*type1
, *type2
;
7054 arg1
= coerce_ref (arg1
);
7055 arg2
= coerce_ref (arg2
);
7056 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7057 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7059 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7060 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7061 return value_binop (arg1
, arg2
, op
);
7070 return value_binop (arg1
, arg2
, op
);
7073 v2
= value_as_long (arg2
);
7075 error (_("second operand of %s must not be zero."), op_string (op
));
7077 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7078 return value_binop (arg1
, arg2
, op
);
7080 v1
= value_as_long (arg1
);
7085 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7086 v
+= v
> 0 ? -1 : 1;
7094 /* Should not reach this point. */
7098 val
= allocate_value (type1
);
7099 store_unsigned_integer (VALUE_CONTENTS_RAW (val
),
7100 TYPE_LENGTH (value_type (val
)), v
);
7105 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7107 if (ada_is_direct_array_type (value_type (arg1
))
7108 || ada_is_direct_array_type (value_type (arg2
)))
7110 arg1
= ada_coerce_to_simple_array (arg1
);
7111 arg2
= ada_coerce_to_simple_array (arg2
);
7112 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
7113 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
7114 error (_("Attempt to compare array with non-array"));
7115 /* FIXME: The following works only for types whose
7116 representations use all bits (no padding or undefined bits)
7117 and do not have user-defined equality. */
7119 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
7120 && memcmp (VALUE_CONTENTS (arg1
), VALUE_CONTENTS (arg2
),
7121 TYPE_LENGTH (value_type (arg1
))) == 0;
7123 return value_equal (arg1
, arg2
);
7127 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
7128 int *pos
, enum noside noside
)
7131 int tem
, tem2
, tem3
;
7133 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
7136 struct value
**argvec
;
7140 op
= exp
->elts
[pc
].opcode
;
7147 unwrap_value (evaluate_subexp_standard
7148 (expect_type
, exp
, pos
, noside
));
7152 struct value
*result
;
7154 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
7155 /* The result type will have code OP_STRING, bashed there from
7156 OP_ARRAY. Bash it back. */
7157 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
7158 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
7164 type
= exp
->elts
[pc
+ 1].type
;
7165 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
7166 if (noside
== EVAL_SKIP
)
7168 if (type
!= ada_check_typedef (value_type (arg1
)))
7170 if (ada_is_fixed_point_type (type
))
7171 arg1
= cast_to_fixed (type
, arg1
);
7172 else if (ada_is_fixed_point_type (value_type (arg1
)))
7173 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
7174 else if (VALUE_LVAL (arg1
) == lval_memory
)
7176 /* This is in case of the really obscure (and undocumented,
7177 but apparently expected) case of (Foo) Bar.all, where Bar
7178 is an integer constant and Foo is a dynamic-sized type.
7179 If we don't do this, ARG1 will simply be relabeled with
7181 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7182 return value_zero (to_static_fixed_type (type
), not_lval
);
7184 ada_to_fixed_value_create
7185 (type
, VALUE_ADDRESS (arg1
) + value_offset (arg1
), 0);
7188 arg1
= value_cast (type
, arg1
);
7194 type
= exp
->elts
[pc
+ 1].type
;
7195 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
7198 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7199 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7200 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7202 if (ada_is_fixed_point_type (value_type (arg1
)))
7203 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
7204 else if (ada_is_fixed_point_type (value_type (arg2
)))
7206 (_("Fixed-point values must be assigned to fixed-point variables"));
7208 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
7209 return ada_value_assign (arg1
, arg2
);
7212 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7213 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7214 if (noside
== EVAL_SKIP
)
7216 if ((ada_is_fixed_point_type (value_type (arg1
))
7217 || ada_is_fixed_point_type (value_type (arg2
)))
7218 && value_type (arg1
) != value_type (arg2
))
7219 error (_("Operands of fixed-point addition must have the same type"));
7220 return value_cast (value_type (arg1
), value_add (arg1
, arg2
));
7223 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7224 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7225 if (noside
== EVAL_SKIP
)
7227 if ((ada_is_fixed_point_type (value_type (arg1
))
7228 || ada_is_fixed_point_type (value_type (arg2
)))
7229 && value_type (arg1
) != value_type (arg2
))
7230 error (_("Operands of fixed-point subtraction must have the same type"));
7231 return value_cast (value_type (arg1
), value_sub (arg1
, arg2
));
7235 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7236 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7237 if (noside
== EVAL_SKIP
)
7239 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7240 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7241 return value_zero (value_type (arg1
), not_lval
);
7244 if (ada_is_fixed_point_type (value_type (arg1
)))
7245 arg1
= cast_from_fixed_to_double (arg1
);
7246 if (ada_is_fixed_point_type (value_type (arg2
)))
7247 arg2
= cast_from_fixed_to_double (arg2
);
7248 return ada_value_binop (arg1
, arg2
, op
);
7253 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7254 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7255 if (noside
== EVAL_SKIP
)
7257 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7258 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7259 return value_zero (value_type (arg1
), not_lval
);
7261 return ada_value_binop (arg1
, arg2
, op
);
7264 case BINOP_NOTEQUAL
:
7265 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7266 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7267 if (noside
== EVAL_SKIP
)
7269 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7272 tem
= ada_value_equal (arg1
, arg2
);
7273 if (op
== BINOP_NOTEQUAL
)
7275 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
7278 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7279 if (noside
== EVAL_SKIP
)
7281 else if (ada_is_fixed_point_type (value_type (arg1
)))
7282 return value_cast (value_type (arg1
), value_neg (arg1
));
7284 return value_neg (arg1
);
7288 if (noside
== EVAL_SKIP
)
7293 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
7294 /* Only encountered when an unresolved symbol occurs in a
7295 context other than a function call, in which case, it is
7297 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7298 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
7299 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7303 (to_static_fixed_type
7304 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7310 unwrap_value (evaluate_subexp_standard
7311 (expect_type
, exp
, pos
, noside
));
7312 return ada_to_fixed_value (arg1
);
7318 /* Allocate arg vector, including space for the function to be
7319 called in argvec[0] and a terminating NULL. */
7320 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7322 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
7324 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
7325 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
7326 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7327 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
7330 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7331 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7334 if (noside
== EVAL_SKIP
)
7338 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
7339 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7340 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
7341 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
7342 && VALUE_LVAL (argvec
[0]) == lval_memory
))
7343 argvec
[0] = value_addr (argvec
[0]);
7345 type
= ada_check_typedef (value_type (argvec
[0]));
7346 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7348 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
7350 case TYPE_CODE_FUNC
:
7351 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7353 case TYPE_CODE_ARRAY
:
7355 case TYPE_CODE_STRUCT
:
7356 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7357 argvec
[0] = ada_value_ind (argvec
[0]);
7358 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7361 error (_("cannot subscript or call something of type `%s'"),
7362 ada_type_name (value_type (argvec
[0])));
7367 switch (TYPE_CODE (type
))
7369 case TYPE_CODE_FUNC
:
7370 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7371 return allocate_value (TYPE_TARGET_TYPE (type
));
7372 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7373 case TYPE_CODE_STRUCT
:
7377 arity
= ada_array_arity (type
);
7378 type
= ada_array_element_type (type
, nargs
);
7380 error (_("cannot subscript or call a record"));
7382 error (_("wrong number of subscripts; expecting %d"), arity
);
7383 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7384 return allocate_value (ada_aligned_type (type
));
7386 unwrap_value (ada_value_subscript
7387 (argvec
[0], nargs
, argvec
+ 1));
7389 case TYPE_CODE_ARRAY
:
7390 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7392 type
= ada_array_element_type (type
, nargs
);
7394 error (_("element type of array unknown"));
7396 return allocate_value (ada_aligned_type (type
));
7399 unwrap_value (ada_value_subscript
7400 (ada_coerce_to_simple_array (argvec
[0]),
7401 nargs
, argvec
+ 1));
7402 case TYPE_CODE_PTR
: /* Pointer to array */
7403 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7404 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7406 type
= ada_array_element_type (type
, nargs
);
7408 error (_("element type of array unknown"));
7410 return allocate_value (ada_aligned_type (type
));
7413 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7414 nargs
, argvec
+ 1));
7417 error (_("Attempt to index or call something other than an \
7418 array or function"));
7423 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7424 struct value
*low_bound_val
=
7425 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7426 struct value
*high_bound_val
=
7427 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7430 low_bound_val
= coerce_ref (low_bound_val
);
7431 high_bound_val
= coerce_ref (high_bound_val
);
7432 low_bound
= pos_atr (low_bound_val
);
7433 high_bound
= pos_atr (high_bound_val
);
7435 if (noside
== EVAL_SKIP
)
7438 /* If this is a reference to an aligner type, then remove all
7440 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7441 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
7442 TYPE_TARGET_TYPE (value_type (array
)) =
7443 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
7445 if (ada_is_packed_array_type (value_type (array
)))
7446 error (_("cannot slice a packed array"));
7448 /* If this is a reference to an array or an array lvalue,
7449 convert to a pointer. */
7450 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7451 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
7452 && VALUE_LVAL (array
) == lval_memory
))
7453 array
= value_addr (array
);
7455 if (noside
== EVAL_AVOID_SIDE_EFFECTS
7456 && ada_is_array_descriptor_type (ada_check_typedef
7457 (value_type (array
))))
7458 return empty_array (ada_type_of_array (array
, 0), low_bound
);
7460 array
= ada_coerce_to_simple_array_ptr (array
);
7462 /* If we have more than one level of pointer indirection,
7463 dereference the value until we get only one level. */
7464 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
7465 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
7467 array
= value_ind (array
);
7469 /* Make sure we really do have an array type before going further,
7470 to avoid a SEGV when trying to get the index type or the target
7471 type later down the road if the debug info generated by
7472 the compiler is incorrect or incomplete. */
7473 if (!ada_is_simple_array_type (value_type (array
)))
7474 error (_("cannot take slice of non-array"));
7476 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
7478 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7479 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
7483 struct type
*arr_type0
=
7484 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
7486 return ada_value_slice_ptr (array
, arr_type0
,
7491 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7493 else if (high_bound
< low_bound
)
7494 return empty_array (value_type (array
), low_bound
);
7496 return ada_value_slice (array
, (int) low_bound
, (int) high_bound
);
7501 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7502 type
= exp
->elts
[pc
+ 1].type
;
7504 if (noside
== EVAL_SKIP
)
7507 switch (TYPE_CODE (type
))
7510 lim_warning (_("Membership test incompletely implemented; \
7511 always returns true"));
7512 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
7514 case TYPE_CODE_RANGE
:
7515 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
7516 arg3
= value_from_longest (builtin_type_int
,
7517 TYPE_HIGH_BOUND (type
));
7519 value_from_longest (builtin_type_int
,
7520 (value_less (arg1
, arg3
)
7521 || value_equal (arg1
, arg3
))
7522 && (value_less (arg2
, arg1
)
7523 || value_equal (arg2
, arg1
)));
7526 case BINOP_IN_BOUNDS
:
7528 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7529 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7531 if (noside
== EVAL_SKIP
)
7534 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7535 return value_zero (builtin_type_int
, not_lval
);
7537 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7539 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
7540 error (_("invalid dimension number to 'range"));
7542 arg3
= ada_array_bound (arg2
, tem
, 1);
7543 arg2
= ada_array_bound (arg2
, tem
, 0);
7546 value_from_longest (builtin_type_int
,
7547 (value_less (arg1
, arg3
)
7548 || value_equal (arg1
, arg3
))
7549 && (value_less (arg2
, arg1
)
7550 || value_equal (arg2
, arg1
)));
7552 case TERNOP_IN_RANGE
:
7553 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7554 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7555 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7557 if (noside
== EVAL_SKIP
)
7561 value_from_longest (builtin_type_int
,
7562 (value_less (arg1
, arg3
)
7563 || value_equal (arg1
, arg3
))
7564 && (value_less (arg2
, arg1
)
7565 || value_equal (arg2
, arg1
)));
7571 struct type
*type_arg
;
7572 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
7574 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7576 type_arg
= exp
->elts
[pc
+ 2].type
;
7580 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7584 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
7585 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
7586 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
7589 if (noside
== EVAL_SKIP
)
7592 if (type_arg
== NULL
)
7594 arg1
= ada_coerce_ref (arg1
);
7596 if (ada_is_packed_array_type (value_type (arg1
)))
7597 arg1
= ada_coerce_to_simple_array (arg1
);
7599 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
7600 error (_("invalid dimension number to '%s"),
7601 ada_attribute_name (op
));
7603 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7605 type
= ada_index_type (value_type (arg1
), tem
);
7608 (_("attempt to take bound of something that is not an array"));
7609 return allocate_value (type
);
7614 default: /* Should never happen. */
7615 error (_("unexpected attribute encountered"));
7617 return ada_array_bound (arg1
, tem
, 0);
7619 return ada_array_bound (arg1
, tem
, 1);
7621 return ada_array_length (arg1
, tem
);
7624 else if (discrete_type_p (type_arg
))
7626 struct type
*range_type
;
7627 char *name
= ada_type_name (type_arg
);
7629 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
7631 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
7632 if (range_type
== NULL
)
7633 range_type
= type_arg
;
7637 error (_("unexpected attribute encountered"));
7639 return discrete_type_low_bound (range_type
);
7641 return discrete_type_high_bound (range_type
);
7643 error (_("the 'length attribute applies only to array types"));
7646 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
7647 error (_("unimplemented type attribute"));
7652 if (ada_is_packed_array_type (type_arg
))
7653 type_arg
= decode_packed_array_type (type_arg
);
7655 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
7656 error (_("invalid dimension number to '%s"),
7657 ada_attribute_name (op
));
7659 type
= ada_index_type (type_arg
, tem
);
7662 (_("attempt to take bound of something that is not an array"));
7663 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7664 return allocate_value (type
);
7669 error (_("unexpected attribute encountered"));
7671 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7672 return value_from_longest (type
, low
);
7674 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
7675 return value_from_longest (type
, high
);
7677 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7678 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
7679 return value_from_longest (type
, high
- low
+ 1);
7685 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7686 if (noside
== EVAL_SKIP
)
7689 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7690 return value_zero (ada_tag_type (arg1
), not_lval
);
7692 return ada_value_tag (arg1
);
7696 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7697 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7698 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7699 if (noside
== EVAL_SKIP
)
7701 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7702 return value_zero (value_type (arg1
), not_lval
);
7704 return value_binop (arg1
, arg2
,
7705 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
7707 case OP_ATR_MODULUS
:
7709 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
7710 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7712 if (noside
== EVAL_SKIP
)
7715 if (!ada_is_modular_type (type_arg
))
7716 error (_("'modulus must be applied to modular type"));
7718 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
7719 ada_modulus (type_arg
));
7724 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7725 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7726 if (noside
== EVAL_SKIP
)
7728 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7729 return value_zero (builtin_type_int
, not_lval
);
7731 return value_pos_atr (arg1
);
7734 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7735 if (noside
== EVAL_SKIP
)
7737 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7738 return value_zero (builtin_type_int
, not_lval
);
7740 return value_from_longest (builtin_type_int
,
7742 * TYPE_LENGTH (value_type (arg1
)));
7745 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7746 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7747 type
= exp
->elts
[pc
+ 2].type
;
7748 if (noside
== EVAL_SKIP
)
7750 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7751 return value_zero (type
, not_lval
);
7753 return value_val_atr (type
, arg1
);
7756 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7757 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7758 if (noside
== EVAL_SKIP
)
7760 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7761 return value_zero (value_type (arg1
), not_lval
);
7763 return value_binop (arg1
, arg2
, op
);
7766 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7767 if (noside
== EVAL_SKIP
)
7773 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7774 if (noside
== EVAL_SKIP
)
7776 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
7777 return value_neg (arg1
);
7782 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7783 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
7784 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7785 if (noside
== EVAL_SKIP
)
7787 type
= ada_check_typedef (value_type (arg1
));
7788 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7790 if (ada_is_array_descriptor_type (type
))
7791 /* GDB allows dereferencing GNAT array descriptors. */
7793 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7794 if (arrType
== NULL
)
7795 error (_("Attempt to dereference null array pointer."));
7796 return value_at_lazy (arrType
, 0);
7798 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7799 || TYPE_CODE (type
) == TYPE_CODE_REF
7800 /* In C you can dereference an array to get the 1st elt. */
7801 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7803 type
= to_static_fixed_type
7805 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
7807 return value_zero (type
, lval_memory
);
7809 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7810 /* GDB allows dereferencing an int. */
7811 return value_zero (builtin_type_int
, lval_memory
);
7813 error (_("Attempt to take contents of a non-pointer value."));
7815 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
7816 type
= ada_check_typedef (value_type (arg1
));
7818 if (ada_is_array_descriptor_type (type
))
7819 /* GDB allows dereferencing GNAT array descriptors. */
7820 return ada_coerce_to_simple_array (arg1
);
7822 return ada_value_ind (arg1
);
7824 case STRUCTOP_STRUCT
:
7825 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7826 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7827 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7828 if (noside
== EVAL_SKIP
)
7830 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7832 struct type
*type1
= value_type (arg1
);
7833 if (ada_is_tagged_type (type1
, 1))
7835 type
= ada_lookup_struct_elt_type (type1
,
7836 &exp
->elts
[pc
+ 2].string
,
7839 /* In this case, we assume that the field COULD exist
7840 in some extension of the type. Return an object of
7841 "type" void, which will match any formal
7842 (see ada_type_match). */
7843 return value_zero (builtin_type_void
, lval_memory
);
7847 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
7850 return value_zero (ada_aligned_type (type
), lval_memory
);
7854 ada_to_fixed_value (unwrap_value
7855 (ada_value_struct_elt
7856 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
7858 /* The value is not supposed to be used. This is here to make it
7859 easier to accommodate expressions that contain types. */
7861 if (noside
== EVAL_SKIP
)
7863 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7864 return allocate_value (builtin_type_void
);
7866 error (_("Attempt to use a type name as an expression"));
7870 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7876 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7877 type name that encodes the 'small and 'delta information.
7878 Otherwise, return NULL. */
7881 fixed_type_info (struct type
*type
)
7883 const char *name
= ada_type_name (type
);
7884 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7886 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7888 const char *tail
= strstr (name
, "___XF_");
7894 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7895 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7900 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7903 ada_is_fixed_point_type (struct type
*type
)
7905 return fixed_type_info (type
) != NULL
;
7908 /* Return non-zero iff TYPE represents a System.Address type. */
7911 ada_is_system_address_type (struct type
*type
)
7913 return (TYPE_NAME (type
)
7914 && strcmp (TYPE_NAME (type
), "system__address") == 0);
7917 /* Assuming that TYPE is the representation of an Ada fixed-point
7918 type, return its delta, or -1 if the type is malformed and the
7919 delta cannot be determined. */
7922 ada_delta (struct type
*type
)
7924 const char *encoding
= fixed_type_info (type
);
7927 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7930 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7933 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7934 factor ('SMALL value) associated with the type. */
7937 scaling_factor (struct type
*type
)
7939 const char *encoding
= fixed_type_info (type
);
7940 unsigned long num0
, den0
, num1
, den1
;
7943 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7948 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7950 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7954 /* Assuming that X is the representation of a value of fixed-point
7955 type TYPE, return its floating-point equivalent. */
7958 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7960 return (DOUBLEST
) x
*scaling_factor (type
);
7963 /* The representation of a fixed-point value of type TYPE
7964 corresponding to the value X. */
7967 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7969 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7973 /* VAX floating formats */
7975 /* Non-zero iff TYPE represents one of the special VAX floating-point
7979 ada_is_vax_floating_type (struct type
*type
)
7982 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7985 && (TYPE_CODE (type
) == TYPE_CODE_INT
7986 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7987 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
7990 /* The type of special VAX floating-point type this is, assuming
7991 ada_is_vax_floating_point. */
7994 ada_vax_float_type_suffix (struct type
*type
)
7996 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7999 /* A value representing the special debugging function that outputs
8000 VAX floating-point values of the type represented by TYPE. Assumes
8001 ada_is_vax_floating_type (TYPE). */
8004 ada_vax_float_print_function (struct type
*type
)
8006 switch (ada_vax_float_type_suffix (type
))
8009 return get_var_value ("DEBUG_STRING_F", 0);
8011 return get_var_value ("DEBUG_STRING_D", 0);
8013 return get_var_value ("DEBUG_STRING_G", 0);
8015 error (_("invalid VAX floating-point type"));
8022 /* Scan STR beginning at position K for a discriminant name, and
8023 return the value of that discriminant field of DVAL in *PX. If
8024 PNEW_K is not null, put the position of the character beyond the
8025 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8026 not alter *PX and *PNEW_K if unsuccessful. */
8029 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
8032 static char *bound_buffer
= NULL
;
8033 static size_t bound_buffer_len
= 0;
8036 struct value
*bound_val
;
8038 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
8041 pend
= strstr (str
+ k
, "__");
8045 k
+= strlen (bound
);
8049 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
8050 bound
= bound_buffer
;
8051 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
8052 bound
[pend
- (str
+ k
)] = '\0';
8056 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
8057 if (bound_val
== NULL
)
8060 *px
= value_as_long (bound_val
);
8066 /* Value of variable named NAME in the current environment. If
8067 no such variable found, then if ERR_MSG is null, returns 0, and
8068 otherwise causes an error with message ERR_MSG. */
8070 static struct value
*
8071 get_var_value (char *name
, char *err_msg
)
8073 struct ada_symbol_info
*syms
;
8076 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
8081 if (err_msg
== NULL
)
8084 error ("%s", err_msg
);
8087 return value_of_variable (syms
[0].sym
, syms
[0].block
);
8090 /* Value of integer variable named NAME in the current environment. If
8091 no such variable found, returns 0, and sets *FLAG to 0. If
8092 successful, sets *FLAG to 1. */
8095 get_int_var_value (char *name
, int *flag
)
8097 struct value
*var_val
= get_var_value (name
, 0);
8109 return value_as_long (var_val
);
8114 /* Return a range type whose base type is that of the range type named
8115 NAME in the current environment, and whose bounds are calculated
8116 from NAME according to the GNAT range encoding conventions.
8117 Extract discriminant values, if needed, from DVAL. If a new type
8118 must be created, allocate in OBJFILE's space. The bounds
8119 information, in general, is encoded in NAME, the base type given in
8120 the named range type. */
8122 static struct type
*
8123 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
8125 struct type
*raw_type
= ada_find_any_type (name
);
8126 struct type
*base_type
;
8129 if (raw_type
== NULL
)
8130 base_type
= builtin_type_int
;
8131 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
8132 base_type
= TYPE_TARGET_TYPE (raw_type
);
8134 base_type
= raw_type
;
8136 subtype_info
= strstr (name
, "___XD");
8137 if (subtype_info
== NULL
)
8141 static char *name_buf
= NULL
;
8142 static size_t name_len
= 0;
8143 int prefix_len
= subtype_info
- name
;
8149 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
8150 strncpy (name_buf
, name
, prefix_len
);
8151 name_buf
[prefix_len
] = '\0';
8154 bounds_str
= strchr (subtype_info
, '_');
8157 if (*subtype_info
== 'L')
8159 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
8160 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
8162 if (bounds_str
[n
] == '_')
8164 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
8171 strcpy (name_buf
+ prefix_len
, "___L");
8172 L
= get_int_var_value (name_buf
, &ok
);
8175 lim_warning (_("Unknown lower bound, using 1."));
8180 if (*subtype_info
== 'U')
8182 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
8183 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
8189 strcpy (name_buf
+ prefix_len
, "___U");
8190 U
= get_int_var_value (name_buf
, &ok
);
8193 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
8198 if (objfile
== NULL
)
8199 objfile
= TYPE_OBJFILE (base_type
);
8200 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
8201 TYPE_NAME (type
) = name
;
8206 /* True iff NAME is the name of a range type. */
8209 ada_is_range_type_name (const char *name
)
8211 return (name
!= NULL
&& strstr (name
, "___XD"));
8217 /* True iff TYPE is an Ada modular type. */
8220 ada_is_modular_type (struct type
*type
)
8222 struct type
*subranged_type
= base_type (type
);
8224 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
8225 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
8226 && TYPE_UNSIGNED (subranged_type
));
8229 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8232 ada_modulus (struct type
* type
)
8234 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
8238 /* Information about operators given special treatment in functions
8240 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
8242 #define ADA_OPERATORS \
8243 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
8244 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
8245 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
8246 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
8247 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
8248 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
8249 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
8250 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
8251 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
8252 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
8253 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
8254 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
8255 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
8256 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
8257 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
8258 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
8261 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
8263 switch (exp
->elts
[pc
- 1].opcode
)
8266 operator_length_standard (exp
, pc
, oplenp
, argsp
);
8269 #define OP_DEFN(op, len, args, binop) \
8270 case op: *oplenp = len; *argsp = args; break;
8277 ada_op_name (enum exp_opcode opcode
)
8282 return op_name_standard (opcode
);
8283 #define OP_DEFN(op, len, args, binop) case op: return #op;
8289 /* As for operator_length, but assumes PC is pointing at the first
8290 element of the operator, and gives meaningful results only for the
8291 Ada-specific operators. */
8294 ada_forward_operator_length (struct expression
*exp
, int pc
,
8295 int *oplenp
, int *argsp
)
8297 switch (exp
->elts
[pc
].opcode
)
8300 *oplenp
= *argsp
= 0;
8302 #define OP_DEFN(op, len, args, binop) \
8303 case op: *oplenp = len; *argsp = args; break;
8310 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
8312 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
8317 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
8321 /* Ada attributes ('Foo). */
8328 case OP_ATR_MODULUS
:
8337 /* XXX: gdb_sprint_host_address, type_sprint */
8338 fprintf_filtered (stream
, _("Type @"));
8339 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
8340 fprintf_filtered (stream
, " (");
8341 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
8342 fprintf_filtered (stream
, ")");
8344 case BINOP_IN_BOUNDS
:
8345 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
8347 case TERNOP_IN_RANGE
:
8351 return dump_subexp_body_standard (exp
, stream
, elt
);
8355 for (i
= 0; i
< nargs
; i
+= 1)
8356 elt
= dump_subexp (exp
, stream
, elt
);
8361 /* The Ada extension of print_subexp (q.v.). */
8364 ada_print_subexp (struct expression
*exp
, int *pos
,
8365 struct ui_file
*stream
, enum precedence prec
)
8369 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
8371 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8376 print_subexp_standard (exp
, pos
, stream
, prec
);
8381 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
8384 case BINOP_IN_BOUNDS
:
8385 /* XXX: sprint_subexp */
8387 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8388 fputs_filtered (" in ", stream
);
8389 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8390 fputs_filtered ("'range", stream
);
8391 if (exp
->elts
[pc
+ 1].longconst
> 1)
8392 fprintf_filtered (stream
, "(%ld)",
8393 (long) exp
->elts
[pc
+ 1].longconst
);
8396 case TERNOP_IN_RANGE
:
8398 if (prec
>= PREC_EQUAL
)
8399 fputs_filtered ("(", stream
);
8400 /* XXX: sprint_subexp */
8401 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8402 fputs_filtered (" in ", stream
);
8403 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8404 fputs_filtered (" .. ", stream
);
8405 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8406 if (prec
>= PREC_EQUAL
)
8407 fputs_filtered (")", stream
);
8416 case OP_ATR_MODULUS
:
8422 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8424 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
8425 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
8429 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8430 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
8434 for (tem
= 1; tem
< nargs
; tem
+= 1)
8436 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
8437 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
8439 fputs_filtered (")", stream
);
8445 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
8446 fputs_filtered ("'(", stream
);
8447 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
8448 fputs_filtered (")", stream
);
8453 /* XXX: sprint_subexp */
8454 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8455 fputs_filtered (" in ", stream
);
8456 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
8461 /* Table mapping opcodes into strings for printing operators
8462 and precedences of the operators. */
8464 static const struct op_print ada_op_print_tab
[] = {
8465 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
8466 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
8467 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
8468 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
8469 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
8470 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
8471 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
8472 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
8473 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
8474 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
8475 {">", BINOP_GTR
, PREC_ORDER
, 0},
8476 {"<", BINOP_LESS
, PREC_ORDER
, 0},
8477 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
8478 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
8479 {"+", BINOP_ADD
, PREC_ADD
, 0},
8480 {"-", BINOP_SUB
, PREC_ADD
, 0},
8481 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8482 {"*", BINOP_MUL
, PREC_MUL
, 0},
8483 {"/", BINOP_DIV
, PREC_MUL
, 0},
8484 {"rem", BINOP_REM
, PREC_MUL
, 0},
8485 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8486 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8487 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8488 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8489 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8490 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8491 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8492 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8493 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
8494 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
8495 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
8499 /* Fundamental Ada Types */
8501 /* Create a fundamental Ada type using default reasonable for the current
8504 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8505 define fundamental types such as "int" or "double". Others (stabs or
8506 DWARF version 2, etc) do define fundamental types. For the formats which
8507 don't provide fundamental types, gdb can create such types using this
8510 FIXME: Some compilers distinguish explicitly signed integral types
8511 (signed short, signed int, signed long) from "regular" integral types
8512 (short, int, long) in the debugging information. There is some dis-
8513 agreement as to how useful this feature is. In particular, gcc does
8514 not support this. Also, only some debugging formats allow the
8515 distinction to be passed on to a debugger. For now, we always just
8516 use "short", "int", or "long" as the type name, for both the implicit
8517 and explicitly signed types. This also makes life easier for the
8518 gdb test suite since we don't have to account for the differences
8519 in output depending upon what the compiler and debugging format
8520 support. We will probably have to re-examine the issue when gdb
8521 starts taking it's fundamental type information directly from the
8522 debugging information supplied by the compiler. fnf@cygnus.com */
8524 static struct type
*
8525 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8527 struct type
*type
= NULL
;
8532 /* FIXME: For now, if we are asked to produce a type not in this
8533 language, create the equivalent of a C integer type with the
8534 name "<?type?>". When all the dust settles from the type
8535 reconstruction work, this should probably become an error. */
8536 type
= init_type (TYPE_CODE_INT
,
8537 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8538 0, "<?type?>", objfile
);
8539 warning (_("internal error: no Ada fundamental type %d"), typeid);
8542 type
= init_type (TYPE_CODE_VOID
,
8543 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8544 0, "void", objfile
);
8547 type
= init_type (TYPE_CODE_INT
,
8548 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8549 0, "character", objfile
);
8551 case FT_SIGNED_CHAR
:
8552 type
= init_type (TYPE_CODE_INT
,
8553 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8554 0, "signed char", objfile
);
8556 case FT_UNSIGNED_CHAR
:
8557 type
= init_type (TYPE_CODE_INT
,
8558 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8559 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8562 type
= init_type (TYPE_CODE_INT
,
8563 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8564 0, "short_integer", objfile
);
8566 case FT_SIGNED_SHORT
:
8567 type
= init_type (TYPE_CODE_INT
,
8568 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8569 0, "short_integer", objfile
);
8571 case FT_UNSIGNED_SHORT
:
8572 type
= init_type (TYPE_CODE_INT
,
8573 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8574 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8577 type
= init_type (TYPE_CODE_INT
,
8578 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8579 0, "integer", objfile
);
8581 case FT_SIGNED_INTEGER
:
8582 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/
8584 0, "integer", objfile
); /* FIXME -fnf */
8586 case FT_UNSIGNED_INTEGER
:
8587 type
= init_type (TYPE_CODE_INT
,
8588 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8589 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8592 type
= init_type (TYPE_CODE_INT
,
8593 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8594 0, "long_integer", objfile
);
8596 case FT_SIGNED_LONG
:
8597 type
= init_type (TYPE_CODE_INT
,
8598 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8599 0, "long_integer", objfile
);
8601 case FT_UNSIGNED_LONG
:
8602 type
= init_type (TYPE_CODE_INT
,
8603 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8604 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8607 type
= init_type (TYPE_CODE_INT
,
8608 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8609 0, "long_long_integer", objfile
);
8611 case FT_SIGNED_LONG_LONG
:
8612 type
= init_type (TYPE_CODE_INT
,
8613 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8614 0, "long_long_integer", objfile
);
8616 case FT_UNSIGNED_LONG_LONG
:
8617 type
= init_type (TYPE_CODE_INT
,
8618 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8619 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8622 type
= init_type (TYPE_CODE_FLT
,
8623 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8624 0, "float", objfile
);
8626 case FT_DBL_PREC_FLOAT
:
8627 type
= init_type (TYPE_CODE_FLT
,
8628 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8629 0, "long_float", objfile
);
8631 case FT_EXT_PREC_FLOAT
:
8632 type
= init_type (TYPE_CODE_FLT
,
8633 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8634 0, "long_long_float", objfile
);
8640 enum ada_primitive_types
{
8641 ada_primitive_type_int
,
8642 ada_primitive_type_long
,
8643 ada_primitive_type_short
,
8644 ada_primitive_type_char
,
8645 ada_primitive_type_float
,
8646 ada_primitive_type_double
,
8647 ada_primitive_type_void
,
8648 ada_primitive_type_long_long
,
8649 ada_primitive_type_long_double
,
8650 ada_primitive_type_natural
,
8651 ada_primitive_type_positive
,
8652 ada_primitive_type_system_address
,
8653 nr_ada_primitive_types
8657 ada_language_arch_info (struct gdbarch
*current_gdbarch
,
8658 struct language_arch_info
*lai
)
8660 const struct builtin_type
*builtin
= builtin_type (current_gdbarch
);
8661 lai
->primitive_type_vector
8662 = GDBARCH_OBSTACK_CALLOC (current_gdbarch
, nr_ada_primitive_types
+ 1,
8664 lai
->primitive_type_vector
[ada_primitive_type_int
] =
8665 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8666 0, "integer", (struct objfile
*) NULL
);
8667 lai
->primitive_type_vector
[ada_primitive_type_long
] =
8668 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8669 0, "long_integer", (struct objfile
*) NULL
);
8670 lai
->primitive_type_vector
[ada_primitive_type_short
] =
8671 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8672 0, "short_integer", (struct objfile
*) NULL
);
8673 lai
->string_char_type
=
8674 lai
->primitive_type_vector
[ada_primitive_type_char
] =
8675 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8676 0, "character", (struct objfile
*) NULL
);
8677 lai
->primitive_type_vector
[ada_primitive_type_float
] =
8678 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8679 0, "float", (struct objfile
*) NULL
);
8680 lai
->primitive_type_vector
[ada_primitive_type_double
] =
8681 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8682 0, "long_float", (struct objfile
*) NULL
);
8683 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
8684 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8685 0, "long_long_integer", (struct objfile
*) NULL
);
8686 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
8687 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8688 0, "long_long_float", (struct objfile
*) NULL
);
8689 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
8690 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8691 0, "natural", (struct objfile
*) NULL
);
8692 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
8693 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8694 0, "positive", (struct objfile
*) NULL
);
8695 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
8697 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
8698 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8699 (struct objfile
*) NULL
));
8700 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
8701 = "system__address";
8704 /* Language vector */
8706 /* Not really used, but needed in the ada_language_defn. */
8709 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8711 ada_emit_char (c
, stream
, quoter
, 1);
8717 warnings_issued
= 0;
8718 return ada_parse ();
8721 static const struct exp_descriptor ada_exp_descriptor
= {
8723 ada_operator_length
,
8725 ada_dump_subexp_body
,
8729 const struct language_defn ada_language_defn
= {
8730 "ada", /* Language name */
8735 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8736 that's not quite what this means. */
8738 &ada_exp_descriptor
,
8742 ada_printchar
, /* Print a character constant */
8743 ada_printstr
, /* Function to print string constant */
8744 emit_char
, /* Function to print single char (not used) */
8745 ada_create_fundamental_type
, /* Create fundamental type in this language */
8746 ada_print_type
, /* Print a type using appropriate syntax */
8747 ada_val_print
, /* Print a value using appropriate syntax */
8748 ada_value_print
, /* Print a top-level value */
8749 NULL
, /* Language specific skip_trampoline */
8750 NULL
, /* value_of_this */
8751 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
8752 basic_lookup_transparent_type
, /* lookup_transparent_type */
8753 ada_la_decode
, /* Language specific symbol demangler */
8754 NULL
, /* Language specific class_name_from_physname */
8755 ada_op_print_tab
, /* expression operators for printing */
8756 0, /* c-style arrays */
8757 1, /* String lower bound */
8759 ada_get_gdb_completer_word_break_characters
,
8760 ada_language_arch_info
,
8765 _initialize_ada_language (void)
8767 add_language (&ada_language_defn
);
8769 varsize_limit
= 65536;
8771 obstack_init (&symbol_list_obstack
);
8773 decoded_names_store
= htab_create_alloc
8774 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
8775 NULL
, xcalloc
, xfree
);