1 /* Ada language support routines for GDB, the GNU debugger. Copyright (C)
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005 Free
4 Software Foundation, Inc.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
26 #include "gdb_string.h"
30 #include "gdb_regex.h"
35 #include "expression.h"
36 #include "parser-defs.h"
42 #include "breakpoint.h"
45 #include "gdb_obstack.h"
47 #include "completer.h"
54 #include "dictionary.h"
55 #include "exceptions.h"
57 #ifndef ADA_RETAIN_DOTS
58 #define ADA_RETAIN_DOTS 0
61 /* Define whether or not the C operator '/' truncates towards zero for
62 differently signed operands (truncation direction is undefined in C).
63 Copied from valarith.c. */
65 #ifndef TRUNCATION_TOWARDS_ZERO
66 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
70 static void extract_string (CORE_ADDR addr
, char *buf
);
72 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
74 static void modify_general_field (char *, LONGEST
, int, int);
76 static struct type
*desc_base_type (struct type
*);
78 static struct type
*desc_bounds_type (struct type
*);
80 static struct value
*desc_bounds (struct value
*);
82 static int fat_pntr_bounds_bitpos (struct type
*);
84 static int fat_pntr_bounds_bitsize (struct type
*);
86 static struct type
*desc_data_type (struct type
*);
88 static struct value
*desc_data (struct value
*);
90 static int fat_pntr_data_bitpos (struct type
*);
92 static int fat_pntr_data_bitsize (struct type
*);
94 static struct value
*desc_one_bound (struct value
*, int, int);
96 static int desc_bound_bitpos (struct type
*, int, int);
98 static int desc_bound_bitsize (struct type
*, int, int);
100 static struct type
*desc_index_type (struct type
*, int);
102 static int desc_arity (struct type
*);
104 static int ada_type_match (struct type
*, struct type
*, int);
106 static int ada_args_match (struct symbol
*, struct value
**, int);
108 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
110 static struct value
*convert_actual (struct value
*, struct type
*,
113 static struct value
*make_array_descriptor (struct type
*, struct value
*,
116 static void ada_add_block_symbols (struct obstack
*,
117 struct block
*, const char *,
118 domain_enum
, struct objfile
*,
119 struct symtab
*, int);
121 static int is_nonfunction (struct ada_symbol_info
*, int);
123 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
124 struct block
*, struct symtab
*);
126 static int num_defns_collected (struct obstack
*);
128 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
130 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
131 *, const char *, int,
134 static struct symtab
*symtab_for_sym (struct symbol
*);
136 static struct value
*resolve_subexp (struct expression
**, int *, int,
139 static void replace_operator_with_call (struct expression
**, int, int, int,
140 struct symbol
*, struct block
*);
142 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
144 static char *ada_op_name (enum exp_opcode
);
146 static const char *ada_decoded_op_name (enum exp_opcode
);
148 static int numeric_type_p (struct type
*);
150 static int integer_type_p (struct type
*);
152 static int scalar_type_p (struct type
*);
154 static int discrete_type_p (struct type
*);
156 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
159 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
162 static struct value
*evaluate_subexp_type (struct expression
*, int *);
164 static int is_dynamic_field (struct type
*, int);
166 static struct type
*to_fixed_variant_branch_type (struct type
*,
168 CORE_ADDR
, struct value
*);
170 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
172 static struct type
*to_fixed_range_type (char *, struct value
*,
175 static struct type
*to_static_fixed_type (struct type
*);
177 static struct value
*unwrap_value (struct value
*);
179 static struct type
*packed_array_type (struct type
*, long *);
181 static struct type
*decode_packed_array_type (struct type
*);
183 static struct value
*decode_packed_array (struct value
*);
185 static struct value
*value_subscript_packed (struct value
*, int,
188 static struct value
*coerce_unspec_val_to_type (struct value
*,
191 static struct value
*get_var_value (char *, char *);
193 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
195 static int equiv_types (struct type
*, struct type
*);
197 static int is_name_suffix (const char *);
199 static int wild_match (const char *, int, const char *);
201 static struct value
*ada_coerce_ref (struct value
*);
203 static LONGEST
pos_atr (struct value
*);
205 static struct value
*value_pos_atr (struct value
*);
207 static struct value
*value_val_atr (struct type
*, struct value
*);
209 static struct symbol
*standard_lookup (const char *, const struct block
*,
212 static struct value
*ada_search_struct_field (char *, struct value
*, int,
215 static struct value
*ada_value_primitive_field (struct value
*, int, int,
218 static int find_struct_field (char *, struct type
*, int,
219 struct type
**, int *, int *, int *);
221 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
224 static struct value
*ada_to_fixed_value (struct value
*);
226 static int ada_resolve_function (struct ada_symbol_info
*, int,
227 struct value
**, int, const char *,
230 static struct value
*ada_coerce_to_simple_array (struct value
*);
232 static int ada_is_direct_array_type (struct type
*);
234 static void ada_language_arch_info (struct gdbarch
*,
235 struct language_arch_info
*);
237 static void check_size (const struct type
*);
241 /* Maximum-sized dynamic type. */
242 static unsigned int varsize_limit
;
244 /* FIXME: brobecker/2003-09-17: No longer a const because it is
245 returned by a function that does not return a const char *. */
246 static char *ada_completer_word_break_characters
=
248 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
250 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
253 /* The name of the symbol to use to get the name of the main subprogram. */
254 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
255 = "__gnat_ada_main_program_name";
257 /* The name of the runtime function called when an exception is raised. */
258 static const char raise_sym_name
[] = "__gnat_raise_nodefer_with_msg";
260 /* The name of the runtime function called when an unhandled exception
262 static const char raise_unhandled_sym_name
[] = "__gnat_unhandled_exception";
264 /* The name of the runtime function called when an assert failure is
266 static const char raise_assert_sym_name
[] =
267 "system__assertions__raise_assert_failure";
269 /* A string that reflects the longest exception expression rewrite,
270 aside from the exception name. */
271 static const char longest_exception_template
[] =
272 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
274 /* Limit on the number of warnings to raise per expression evaluation. */
275 static int warning_limit
= 2;
277 /* Number of warning messages issued; reset to 0 by cleanups after
278 expression evaluation. */
279 static int warnings_issued
= 0;
281 static const char *known_runtime_file_name_patterns
[] = {
282 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
285 static const char *known_auxiliary_function_name_patterns
[] = {
286 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
289 /* Space for allocating results of ada_lookup_symbol_list. */
290 static struct obstack symbol_list_obstack
;
296 ada_get_gdb_completer_word_break_characters (void)
298 return ada_completer_word_break_characters
;
301 /* Print an array element index using the Ada syntax. */
304 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
305 int format
, enum val_prettyprint pretty
)
307 LA_VALUE_PRINT (index_value
, stream
, format
, pretty
);
308 fprintf_filtered (stream
, " => ");
311 /* Read the string located at ADDR from the inferior and store the
315 extract_string (CORE_ADDR addr
, char *buf
)
319 /* Loop, reading one byte at a time, until we reach the '\000'
320 end-of-string marker. */
323 target_read_memory (addr
+ char_index
* sizeof (char),
324 buf
+ char_index
* sizeof (char), sizeof (char));
327 while (buf
[char_index
- 1] != '\000');
330 /* Assuming VECT points to an array of *SIZE objects of size
331 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
332 updating *SIZE as necessary and returning the (new) array. */
335 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
337 if (*size
< min_size
)
340 if (*size
< min_size
)
342 vect
= xrealloc (vect
, *size
* element_size
);
347 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
348 suffix of FIELD_NAME beginning "___". */
351 field_name_match (const char *field_name
, const char *target
)
353 int len
= strlen (target
);
355 (strncmp (field_name
, target
, len
) == 0
356 && (field_name
[len
] == '\0'
357 || (strncmp (field_name
+ len
, "___", 3) == 0
358 && strcmp (field_name
+ strlen (field_name
) - 6,
363 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
364 FIELD_NAME, and return its index. This function also handles fields
365 whose name have ___ suffixes because the compiler sometimes alters
366 their name by adding such a suffix to represent fields with certain
367 constraints. If the field could not be found, return a negative
368 number if MAYBE_MISSING is set. Otherwise raise an error. */
371 ada_get_field_index (const struct type
*type
, const char *field_name
,
375 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
376 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
380 error (_("Unable to find field %s in struct %s. Aborting"),
381 field_name
, TYPE_NAME (type
));
386 /* The length of the prefix of NAME prior to any "___" suffix. */
389 ada_name_prefix_len (const char *name
)
395 const char *p
= strstr (name
, "___");
397 return strlen (name
);
403 /* Return non-zero if SUFFIX is a suffix of STR.
404 Return zero if STR is null. */
407 is_suffix (const char *str
, const char *suffix
)
413 len2
= strlen (suffix
);
414 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
417 /* Create a value of type TYPE whose contents come from VALADDR, if it
418 is non-null, and whose memory address (in the inferior) is
422 value_from_contents_and_address (struct type
*type
,
423 const gdb_byte
*valaddr
,
426 struct value
*v
= allocate_value (type
);
428 set_value_lazy (v
, 1);
430 memcpy (value_contents_raw (v
), valaddr
, TYPE_LENGTH (type
));
431 VALUE_ADDRESS (v
) = address
;
433 VALUE_LVAL (v
) = lval_memory
;
437 /* The contents of value VAL, treated as a value of type TYPE. The
438 result is an lval in memory if VAL is. */
440 static struct value
*
441 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
443 type
= ada_check_typedef (type
);
444 if (value_type (val
) == type
)
448 struct value
*result
;
450 /* Make sure that the object size is not unreasonable before
451 trying to allocate some memory for it. */
454 result
= allocate_value (type
);
455 VALUE_LVAL (result
) = VALUE_LVAL (val
);
456 set_value_bitsize (result
, value_bitsize (val
));
457 set_value_bitpos (result
, value_bitpos (val
));
458 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + value_offset (val
);
460 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
461 set_value_lazy (result
, 1);
463 memcpy (value_contents_raw (result
), value_contents (val
),
469 static const gdb_byte
*
470 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
475 return valaddr
+ offset
;
479 cond_offset_target (CORE_ADDR address
, long offset
)
484 return address
+ offset
;
487 /* Issue a warning (as for the definition of warning in utils.c, but
488 with exactly one argument rather than ...), unless the limit on the
489 number of warnings has passed during the evaluation of the current
492 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
493 provided by "complaint". */
494 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
497 lim_warning (const char *format
, ...)
500 va_start (args
, format
);
502 warnings_issued
+= 1;
503 if (warnings_issued
<= warning_limit
)
504 vwarning (format
, args
);
509 /* Issue an error if the size of an object of type T is unreasonable,
510 i.e. if it would be a bad idea to allocate a value of this type in
514 check_size (const struct type
*type
)
516 if (TYPE_LENGTH (type
) > varsize_limit
)
517 error (_("object size is larger than varsize-limit"));
521 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
522 gdbtypes.h, but some of the necessary definitions in that file
523 seem to have gone missing. */
525 /* Maximum value of a SIZE-byte signed integer type. */
527 max_of_size (int size
)
529 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
530 return top_bit
| (top_bit
- 1);
533 /* Minimum value of a SIZE-byte signed integer type. */
535 min_of_size (int size
)
537 return -max_of_size (size
) - 1;
540 /* Maximum value of a SIZE-byte unsigned integer type. */
542 umax_of_size (int size
)
544 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
545 return top_bit
| (top_bit
- 1);
548 /* Maximum value of integral type T, as a signed quantity. */
550 max_of_type (struct type
*t
)
552 if (TYPE_UNSIGNED (t
))
553 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
555 return max_of_size (TYPE_LENGTH (t
));
558 /* Minimum value of integral type T, as a signed quantity. */
560 min_of_type (struct type
*t
)
562 if (TYPE_UNSIGNED (t
))
565 return min_of_size (TYPE_LENGTH (t
));
568 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
569 static struct value
*
570 discrete_type_high_bound (struct type
*type
)
572 switch (TYPE_CODE (type
))
574 case TYPE_CODE_RANGE
:
575 return value_from_longest (TYPE_TARGET_TYPE (type
),
576 TYPE_HIGH_BOUND (type
));
579 value_from_longest (type
,
580 TYPE_FIELD_BITPOS (type
,
581 TYPE_NFIELDS (type
) - 1));
583 return value_from_longest (type
, max_of_type (type
));
585 error (_("Unexpected type in discrete_type_high_bound."));
589 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
590 static struct value
*
591 discrete_type_low_bound (struct type
*type
)
593 switch (TYPE_CODE (type
))
595 case TYPE_CODE_RANGE
:
596 return value_from_longest (TYPE_TARGET_TYPE (type
),
597 TYPE_LOW_BOUND (type
));
599 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
601 return value_from_longest (type
, min_of_type (type
));
603 error (_("Unexpected type in discrete_type_low_bound."));
607 /* The identity on non-range types. For range types, the underlying
608 non-range scalar type. */
611 base_type (struct type
*type
)
613 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
615 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
617 type
= TYPE_TARGET_TYPE (type
);
623 /* Language Selection */
625 /* If the main program is in Ada, return language_ada, otherwise return LANG
626 (the main program is in Ada iif the adainit symbol is found).
628 MAIN_PST is not used. */
631 ada_update_initial_language (enum language lang
,
632 struct partial_symtab
*main_pst
)
634 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
635 (struct objfile
*) NULL
) != NULL
)
641 /* If the main procedure is written in Ada, then return its name.
642 The result is good until the next call. Return NULL if the main
643 procedure doesn't appear to be in Ada. */
648 struct minimal_symbol
*msym
;
649 CORE_ADDR main_program_name_addr
;
650 static char main_program_name
[1024];
652 /* For Ada, the name of the main procedure is stored in a specific
653 string constant, generated by the binder. Look for that symbol,
654 extract its address, and then read that string. If we didn't find
655 that string, then most probably the main procedure is not written
657 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
661 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
662 if (main_program_name_addr
== 0)
663 error (_("Invalid address for Ada main program name."));
665 extract_string (main_program_name_addr
, main_program_name
);
666 return main_program_name
;
669 /* The main procedure doesn't seem to be in Ada. */
675 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
678 const struct ada_opname_map ada_opname_table
[] = {
679 {"Oadd", "\"+\"", BINOP_ADD
},
680 {"Osubtract", "\"-\"", BINOP_SUB
},
681 {"Omultiply", "\"*\"", BINOP_MUL
},
682 {"Odivide", "\"/\"", BINOP_DIV
},
683 {"Omod", "\"mod\"", BINOP_MOD
},
684 {"Orem", "\"rem\"", BINOP_REM
},
685 {"Oexpon", "\"**\"", BINOP_EXP
},
686 {"Olt", "\"<\"", BINOP_LESS
},
687 {"Ole", "\"<=\"", BINOP_LEQ
},
688 {"Ogt", "\">\"", BINOP_GTR
},
689 {"Oge", "\">=\"", BINOP_GEQ
},
690 {"Oeq", "\"=\"", BINOP_EQUAL
},
691 {"One", "\"/=\"", BINOP_NOTEQUAL
},
692 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
693 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
694 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
695 {"Oconcat", "\"&\"", BINOP_CONCAT
},
696 {"Oabs", "\"abs\"", UNOP_ABS
},
697 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
698 {"Oadd", "\"+\"", UNOP_PLUS
},
699 {"Osubtract", "\"-\"", UNOP_NEG
},
703 /* Return non-zero if STR should be suppressed in info listings. */
706 is_suppressed_name (const char *str
)
708 if (strncmp (str
, "_ada_", 5) == 0)
710 if (str
[0] == '_' || str
[0] == '\000')
715 const char *suffix
= strstr (str
, "___");
716 if (suffix
!= NULL
&& suffix
[3] != 'X')
719 suffix
= str
+ strlen (str
);
720 for (p
= suffix
- 1; p
!= str
; p
-= 1)
724 if (p
[0] == 'X' && p
[-1] != '_')
728 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
729 if (strncmp (ada_opname_table
[i
].encoded
, p
,
730 strlen (ada_opname_table
[i
].encoded
)) == 0)
739 /* The "encoded" form of DECODED, according to GNAT conventions.
740 The result is valid until the next call to ada_encode. */
743 ada_encode (const char *decoded
)
745 static char *encoding_buffer
= NULL
;
746 static size_t encoding_buffer_size
= 0;
753 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
754 2 * strlen (decoded
) + 10);
757 for (p
= decoded
; *p
!= '\0'; p
+= 1)
759 if (!ADA_RETAIN_DOTS
&& *p
== '.')
761 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
766 const struct ada_opname_map
*mapping
;
768 for (mapping
= ada_opname_table
;
769 mapping
->encoded
!= NULL
770 && strncmp (mapping
->decoded
, p
,
771 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
773 if (mapping
->encoded
== NULL
)
774 error (_("invalid Ada operator name: %s"), p
);
775 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
776 k
+= strlen (mapping
->encoded
);
781 encoding_buffer
[k
] = *p
;
786 encoding_buffer
[k
] = '\0';
787 return encoding_buffer
;
790 /* Return NAME folded to lower case, or, if surrounded by single
791 quotes, unfolded, but with the quotes stripped away. Result good
795 ada_fold_name (const char *name
)
797 static char *fold_buffer
= NULL
;
798 static size_t fold_buffer_size
= 0;
800 int len
= strlen (name
);
801 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
805 strncpy (fold_buffer
, name
+ 1, len
- 2);
806 fold_buffer
[len
- 2] = '\000';
811 for (i
= 0; i
<= len
; i
+= 1)
812 fold_buffer
[i
] = tolower (name
[i
]);
818 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
821 is_lower_alphanum (const char c
)
823 return (isdigit (c
) || (isalpha (c
) && islower (c
)));
827 . Discard trailing .{DIGIT}+, ${DIGIT}+ or ___{DIGIT}+
828 These are suffixes introduced by GNAT5 to nested subprogram
829 names, and do not serve any purpose for the debugger.
830 . Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
831 . Discard final N if it follows a lowercase alphanumeric character
832 (protected object subprogram suffix)
833 . Convert other instances of embedded "__" to `.'.
834 . Discard leading _ada_.
835 . Convert operator names to the appropriate quoted symbols.
836 . Remove everything after first ___ if it is followed by
838 . Replace TK__ with __, and a trailing B or TKB with nothing.
839 . Replace _[EB]{DIGIT}+[sb] with nothing (protected object entries)
840 . Put symbols that should be suppressed in <...> brackets.
841 . Remove trailing X[bn]* suffix (indicating names in package bodies).
843 The resulting string is valid until the next call of ada_decode.
844 If the string is unchanged by demangling, the original string pointer
848 ada_decode (const char *encoded
)
855 static char *decoding_buffer
= NULL
;
856 static size_t decoding_buffer_size
= 0;
858 if (strncmp (encoded
, "_ada_", 5) == 0)
861 if (encoded
[0] == '_' || encoded
[0] == '<')
864 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+ or __{DIGIT}+. */
865 len0
= strlen (encoded
);
866 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
869 while (i
> 0 && isdigit (encoded
[i
]))
871 if (i
>= 0 && encoded
[i
] == '.')
873 else if (i
>= 0 && encoded
[i
] == '$')
875 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
877 else if (i
>= 1 && strncmp (encoded
+ i
- 1, "__", 2) == 0)
881 /* Remove trailing N. */
883 /* Protected entry subprograms are broken into two
884 separate subprograms: The first one is unprotected, and has
885 a 'N' suffix; the second is the protected version, and has
886 the 'P' suffix. The second calls the first one after handling
887 the protection. Since the P subprograms are internally generated,
888 we leave these names undecoded, giving the user a clue that this
889 entity is internal. */
892 && encoded
[len0
- 1] == 'N'
893 && (isdigit (encoded
[len0
- 2]) || islower (encoded
[len0
- 2])))
896 /* Remove the ___X.* suffix if present. Do not forget to verify that
897 the suffix is located before the current "end" of ENCODED. We want
898 to avoid re-matching parts of ENCODED that have previously been
899 marked as discarded (by decrementing LEN0). */
900 p
= strstr (encoded
, "___");
901 if (p
!= NULL
&& p
- encoded
< len0
- 3)
909 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
912 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
915 /* Make decoded big enough for possible expansion by operator name. */
916 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
917 decoded
= decoding_buffer
;
919 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
922 while ((i
>= 0 && isdigit (encoded
[i
]))
923 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
925 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
927 else if (encoded
[i
] == '$')
931 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
932 decoded
[j
] = encoded
[i
];
937 if (at_start_name
&& encoded
[i
] == 'O')
940 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
942 int op_len
= strlen (ada_opname_table
[k
].encoded
);
943 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
945 && !isalnum (encoded
[i
+ op_len
]))
947 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
950 j
+= strlen (ada_opname_table
[k
].decoded
);
954 if (ada_opname_table
[k
].encoded
!= NULL
)
959 /* Replace "TK__" with "__", which will eventually be translated
960 into "." (just below). */
962 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
965 /* Remove _E{DIGITS}+[sb] */
967 /* Just as for protected object subprograms, there are 2 categories
968 of subprograms created by the compiler for each entry. The first
969 one implements the actual entry code, and has a suffix following
970 the convention above; the second one implements the barrier and
971 uses the same convention as above, except that the 'E' is replaced
974 Just as above, we do not decode the name of barrier functions
975 to give the user a clue that the code he is debugging has been
976 internally generated. */
978 if (len0
- i
> 3 && encoded
[i
] == '_' && encoded
[i
+1] == 'E'
979 && isdigit (encoded
[i
+2]))
983 while (k
< len0
&& isdigit (encoded
[k
]))
987 && (encoded
[k
] == 'b' || encoded
[k
] == 's'))
990 /* Just as an extra precaution, make sure that if this
991 suffix is followed by anything else, it is a '_'.
992 Otherwise, we matched this sequence by accident. */
994 || (k
< len0
&& encoded
[k
] == '_'))
999 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1000 the GNAT front-end in protected object subprograms. */
1003 && encoded
[i
] == 'N' && encoded
[i
+1] == '_' && encoded
[i
+2] == '_')
1005 /* Backtrack a bit up until we reach either the begining of
1006 the encoded name, or "__". Make sure that we only find
1007 digits or lowercase characters. */
1008 const char *ptr
= encoded
+ i
- 1;
1010 while (ptr
>= encoded
&& is_lower_alphanum (ptr
[0]))
1013 || (ptr
> encoded
&& ptr
[0] == '_' && ptr
[-1] == '_'))
1017 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1021 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1025 else if (!ADA_RETAIN_DOTS
1026 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1035 decoded
[j
] = encoded
[i
];
1040 decoded
[j
] = '\000';
1042 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1043 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1046 if (strcmp (decoded
, encoded
) == 0)
1052 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1053 decoded
= decoding_buffer
;
1054 if (encoded
[0] == '<')
1055 strcpy (decoded
, encoded
);
1057 sprintf (decoded
, "<%s>", encoded
);
1062 /* Table for keeping permanent unique copies of decoded names. Once
1063 allocated, names in this table are never released. While this is a
1064 storage leak, it should not be significant unless there are massive
1065 changes in the set of decoded names in successive versions of a
1066 symbol table loaded during a single session. */
1067 static struct htab
*decoded_names_store
;
1069 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1070 in the language-specific part of GSYMBOL, if it has not been
1071 previously computed. Tries to save the decoded name in the same
1072 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1073 in any case, the decoded symbol has a lifetime at least that of
1075 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1076 const, but nevertheless modified to a semantically equivalent form
1077 when a decoded name is cached in it.
1081 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1084 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1085 if (*resultp
== NULL
)
1087 const char *decoded
= ada_decode (gsymbol
->name
);
1088 if (gsymbol
->bfd_section
!= NULL
)
1090 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
1093 struct objfile
*objf
;
1096 if (obfd
== objf
->obfd
)
1098 *resultp
= obsavestring (decoded
, strlen (decoded
),
1099 &objf
->objfile_obstack
);
1105 /* Sometimes, we can't find a corresponding objfile, in which
1106 case, we put the result on the heap. Since we only decode
1107 when needed, we hope this usually does not cause a
1108 significant memory leak (FIXME). */
1109 if (*resultp
== NULL
)
1111 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1114 *slot
= xstrdup (decoded
);
1123 ada_la_decode (const char *encoded
, int options
)
1125 return xstrdup (ada_decode (encoded
));
1128 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1129 suffixes that encode debugging information or leading _ada_ on
1130 SYM_NAME (see is_name_suffix commentary for the debugging
1131 information that is ignored). If WILD, then NAME need only match a
1132 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1133 either argument is NULL. */
1136 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1138 if (sym_name
== NULL
|| name
== NULL
)
1141 return wild_match (name
, strlen (name
), sym_name
);
1144 int len_name
= strlen (name
);
1145 return (strncmp (sym_name
, name
, len_name
) == 0
1146 && is_name_suffix (sym_name
+ len_name
))
1147 || (strncmp (sym_name
, "_ada_", 5) == 0
1148 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1149 && is_name_suffix (sym_name
+ len_name
+ 5));
1153 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1154 suppressed in info listings. */
1157 ada_suppress_symbol_printing (struct symbol
*sym
)
1159 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1162 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1168 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1170 static char *bound_name
[] = {
1171 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1172 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1175 /* Maximum number of array dimensions we are prepared to handle. */
1177 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1179 /* Like modify_field, but allows bitpos > wordlength. */
1182 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1184 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1188 /* The desc_* routines return primitive portions of array descriptors
1191 /* The descriptor or array type, if any, indicated by TYPE; removes
1192 level of indirection, if needed. */
1194 static struct type
*
1195 desc_base_type (struct type
*type
)
1199 type
= ada_check_typedef (type
);
1201 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1202 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1203 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1208 /* True iff TYPE indicates a "thin" array pointer type. */
1211 is_thin_pntr (struct type
*type
)
1214 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1215 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1218 /* The descriptor type for thin pointer type TYPE. */
1220 static struct type
*
1221 thin_descriptor_type (struct type
*type
)
1223 struct type
*base_type
= desc_base_type (type
);
1224 if (base_type
== NULL
)
1226 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1230 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1231 if (alt_type
== NULL
)
1238 /* A pointer to the array data for thin-pointer value VAL. */
1240 static struct value
*
1241 thin_data_pntr (struct value
*val
)
1243 struct type
*type
= value_type (val
);
1244 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1245 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1248 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1249 VALUE_ADDRESS (val
) + value_offset (val
));
1252 /* True iff TYPE indicates a "thick" array pointer type. */
1255 is_thick_pntr (struct type
*type
)
1257 type
= desc_base_type (type
);
1258 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1259 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1262 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1263 pointer to one, the type of its bounds data; otherwise, NULL. */
1265 static struct type
*
1266 desc_bounds_type (struct type
*type
)
1270 type
= desc_base_type (type
);
1274 else if (is_thin_pntr (type
))
1276 type
= thin_descriptor_type (type
);
1279 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1281 return ada_check_typedef (r
);
1283 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1285 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1287 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1292 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1293 one, a pointer to its bounds data. Otherwise NULL. */
1295 static struct value
*
1296 desc_bounds (struct value
*arr
)
1298 struct type
*type
= ada_check_typedef (value_type (arr
));
1299 if (is_thin_pntr (type
))
1301 struct type
*bounds_type
=
1302 desc_bounds_type (thin_descriptor_type (type
));
1305 if (desc_bounds_type
== NULL
)
1306 error (_("Bad GNAT array descriptor"));
1308 /* NOTE: The following calculation is not really kosher, but
1309 since desc_type is an XVE-encoded type (and shouldn't be),
1310 the correct calculation is a real pain. FIXME (and fix GCC). */
1311 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1312 addr
= value_as_long (arr
);
1314 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1317 value_from_longest (lookup_pointer_type (bounds_type
),
1318 addr
- TYPE_LENGTH (bounds_type
));
1321 else if (is_thick_pntr (type
))
1322 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1323 _("Bad GNAT array descriptor"));
1328 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1329 position of the field containing the address of the bounds data. */
1332 fat_pntr_bounds_bitpos (struct type
*type
)
1334 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1337 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1338 size of the field containing the address of the bounds data. */
1341 fat_pntr_bounds_bitsize (struct type
*type
)
1343 type
= desc_base_type (type
);
1345 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1346 return TYPE_FIELD_BITSIZE (type
, 1);
1348 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1351 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1352 pointer to one, the type of its array data (a
1353 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1354 ada_type_of_array to get an array type with bounds data. */
1356 static struct type
*
1357 desc_data_type (struct type
*type
)
1359 type
= desc_base_type (type
);
1361 /* NOTE: The following is bogus; see comment in desc_bounds. */
1362 if (is_thin_pntr (type
))
1363 return lookup_pointer_type
1364 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1365 else if (is_thick_pntr (type
))
1366 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1371 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1374 static struct value
*
1375 desc_data (struct value
*arr
)
1377 struct type
*type
= value_type (arr
);
1378 if (is_thin_pntr (type
))
1379 return thin_data_pntr (arr
);
1380 else if (is_thick_pntr (type
))
1381 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1382 _("Bad GNAT array descriptor"));
1388 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1389 position of the field containing the address of the data. */
1392 fat_pntr_data_bitpos (struct type
*type
)
1394 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1397 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1398 size of the field containing the address of the data. */
1401 fat_pntr_data_bitsize (struct type
*type
)
1403 type
= desc_base_type (type
);
1405 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1406 return TYPE_FIELD_BITSIZE (type
, 0);
1408 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1411 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1412 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1413 bound, if WHICH is 1. The first bound is I=1. */
1415 static struct value
*
1416 desc_one_bound (struct value
*bounds
, int i
, int which
)
1418 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1419 _("Bad GNAT array descriptor bounds"));
1422 /* If BOUNDS is an array-bounds structure type, return the bit position
1423 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1424 bound, if WHICH is 1. The first bound is I=1. */
1427 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1429 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1432 /* If BOUNDS is an array-bounds structure type, return the bit field size
1433 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1434 bound, if WHICH is 1. The first bound is I=1. */
1437 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1439 type
= desc_base_type (type
);
1441 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1442 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1444 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1447 /* If TYPE is the type of an array-bounds structure, the type of its
1448 Ith bound (numbering from 1). Otherwise, NULL. */
1450 static struct type
*
1451 desc_index_type (struct type
*type
, int i
)
1453 type
= desc_base_type (type
);
1455 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1456 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1461 /* The number of index positions in the array-bounds type TYPE.
1462 Return 0 if TYPE is NULL. */
1465 desc_arity (struct type
*type
)
1467 type
= desc_base_type (type
);
1470 return TYPE_NFIELDS (type
) / 2;
1474 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1475 an array descriptor type (representing an unconstrained array
1479 ada_is_direct_array_type (struct type
*type
)
1483 type
= ada_check_typedef (type
);
1484 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1485 || ada_is_array_descriptor_type (type
));
1488 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1491 ada_is_simple_array_type (struct type
*type
)
1495 type
= ada_check_typedef (type
);
1496 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1497 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1498 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1501 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1504 ada_is_array_descriptor_type (struct type
*type
)
1506 struct type
*data_type
= desc_data_type (type
);
1510 type
= ada_check_typedef (type
);
1513 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1514 && TYPE_TARGET_TYPE (data_type
) != NULL
1515 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1516 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1517 && desc_arity (desc_bounds_type (type
)) > 0;
1520 /* Non-zero iff type is a partially mal-formed GNAT array
1521 descriptor. FIXME: This is to compensate for some problems with
1522 debugging output from GNAT. Re-examine periodically to see if it
1526 ada_is_bogus_array_descriptor (struct type
*type
)
1530 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1531 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1532 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1533 && !ada_is_array_descriptor_type (type
);
1537 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1538 (fat pointer) returns the type of the array data described---specifically,
1539 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1540 in from the descriptor; otherwise, they are left unspecified. If
1541 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1542 returns NULL. The result is simply the type of ARR if ARR is not
1545 ada_type_of_array (struct value
*arr
, int bounds
)
1547 if (ada_is_packed_array_type (value_type (arr
)))
1548 return decode_packed_array_type (value_type (arr
));
1550 if (!ada_is_array_descriptor_type (value_type (arr
)))
1551 return value_type (arr
);
1555 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1558 struct type
*elt_type
;
1560 struct value
*descriptor
;
1561 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1563 elt_type
= ada_array_element_type (value_type (arr
), -1);
1564 arity
= ada_array_arity (value_type (arr
));
1566 if (elt_type
== NULL
|| arity
== 0)
1567 return ada_check_typedef (value_type (arr
));
1569 descriptor
= desc_bounds (arr
);
1570 if (value_as_long (descriptor
) == 0)
1574 struct type
*range_type
= alloc_type (objf
);
1575 struct type
*array_type
= alloc_type (objf
);
1576 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1577 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1580 create_range_type (range_type
, value_type (low
),
1581 longest_to_int (value_as_long (low
)),
1582 longest_to_int (value_as_long (high
)));
1583 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1586 return lookup_pointer_type (elt_type
);
1590 /* If ARR does not represent an array, returns ARR unchanged.
1591 Otherwise, returns either a standard GDB array with bounds set
1592 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1593 GDB array. Returns NULL if ARR is a null fat pointer. */
1596 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1598 if (ada_is_array_descriptor_type (value_type (arr
)))
1600 struct type
*arrType
= ada_type_of_array (arr
, 1);
1601 if (arrType
== NULL
)
1603 return value_cast (arrType
, value_copy (desc_data (arr
)));
1605 else if (ada_is_packed_array_type (value_type (arr
)))
1606 return decode_packed_array (arr
);
1611 /* If ARR does not represent an array, returns ARR unchanged.
1612 Otherwise, returns a standard GDB array describing ARR (which may
1613 be ARR itself if it already is in the proper form). */
1615 static struct value
*
1616 ada_coerce_to_simple_array (struct value
*arr
)
1618 if (ada_is_array_descriptor_type (value_type (arr
)))
1620 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1622 error (_("Bounds unavailable for null array pointer."));
1623 check_size (TYPE_TARGET_TYPE (value_type (arrVal
)));
1624 return value_ind (arrVal
);
1626 else if (ada_is_packed_array_type (value_type (arr
)))
1627 return decode_packed_array (arr
);
1632 /* If TYPE represents a GNAT array type, return it translated to an
1633 ordinary GDB array type (possibly with BITSIZE fields indicating
1634 packing). For other types, is the identity. */
1637 ada_coerce_to_simple_array_type (struct type
*type
)
1639 struct value
*mark
= value_mark ();
1640 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1641 struct type
*result
;
1642 deprecated_set_value_type (dummy
, type
);
1643 result
= ada_type_of_array (dummy
, 0);
1644 value_free_to_mark (mark
);
1648 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1651 ada_is_packed_array_type (struct type
*type
)
1655 type
= desc_base_type (type
);
1656 type
= ada_check_typedef (type
);
1658 ada_type_name (type
) != NULL
1659 && strstr (ada_type_name (type
), "___XP") != NULL
;
1662 /* Given that TYPE is a standard GDB array type with all bounds filled
1663 in, and that the element size of its ultimate scalar constituents
1664 (that is, either its elements, or, if it is an array of arrays, its
1665 elements' elements, etc.) is *ELT_BITS, return an identical type,
1666 but with the bit sizes of its elements (and those of any
1667 constituent arrays) recorded in the BITSIZE components of its
1668 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1671 static struct type
*
1672 packed_array_type (struct type
*type
, long *elt_bits
)
1674 struct type
*new_elt_type
;
1675 struct type
*new_type
;
1676 LONGEST low_bound
, high_bound
;
1678 type
= ada_check_typedef (type
);
1679 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1682 new_type
= alloc_type (TYPE_OBJFILE (type
));
1683 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1685 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1686 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1687 TYPE_NAME (new_type
) = ada_type_name (type
);
1689 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1690 &low_bound
, &high_bound
) < 0)
1691 low_bound
= high_bound
= 0;
1692 if (high_bound
< low_bound
)
1693 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1696 *elt_bits
*= (high_bound
- low_bound
+ 1);
1697 TYPE_LENGTH (new_type
) =
1698 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1701 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1705 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1707 static struct type
*
1708 decode_packed_array_type (struct type
*type
)
1711 struct block
**blocks
;
1712 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
1713 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1714 char *tail
= strstr (raw_name
, "___XP");
1715 struct type
*shadow_type
;
1719 type
= desc_base_type (type
);
1721 memcpy (name
, raw_name
, tail
- raw_name
);
1722 name
[tail
- raw_name
] = '\000';
1724 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1725 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1727 lim_warning (_("could not find bounds information on packed array"));
1730 shadow_type
= SYMBOL_TYPE (sym
);
1732 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1734 lim_warning (_("could not understand bounds information on packed array"));
1738 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1741 (_("could not understand bit size information on packed array"));
1745 return packed_array_type (shadow_type
, &bits
);
1748 /* Given that ARR is a struct value *indicating a GNAT packed array,
1749 returns a simple array that denotes that array. Its type is a
1750 standard GDB array type except that the BITSIZEs of the array
1751 target types are set to the number of bits in each element, and the
1752 type length is set appropriately. */
1754 static struct value
*
1755 decode_packed_array (struct value
*arr
)
1759 arr
= ada_coerce_ref (arr
);
1760 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1761 arr
= ada_value_ind (arr
);
1763 type
= decode_packed_array_type (value_type (arr
));
1766 error (_("can't unpack array"));
1770 if (BITS_BIG_ENDIAN
&& ada_is_modular_type (value_type (arr
)))
1772 /* This is a (right-justified) modular type representing a packed
1773 array with no wrapper. In order to interpret the value through
1774 the (left-justified) packed array type we just built, we must
1775 first left-justify it. */
1776 int bit_size
, bit_pos
;
1779 mod
= ada_modulus (value_type (arr
)) - 1;
1786 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1787 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1788 bit_pos
/ HOST_CHAR_BIT
,
1789 bit_pos
% HOST_CHAR_BIT
,
1794 return coerce_unspec_val_to_type (arr
, type
);
1798 /* The value of the element of packed array ARR at the ARITY indices
1799 given in IND. ARR must be a simple array. */
1801 static struct value
*
1802 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1805 int bits
, elt_off
, bit_off
;
1806 long elt_total_bit_offset
;
1807 struct type
*elt_type
;
1811 elt_total_bit_offset
= 0;
1812 elt_type
= ada_check_typedef (value_type (arr
));
1813 for (i
= 0; i
< arity
; i
+= 1)
1815 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1816 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1818 (_("attempt to do packed indexing of something other than a packed array"));
1821 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1822 LONGEST lowerbound
, upperbound
;
1825 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1827 lim_warning (_("don't know bounds of array"));
1828 lowerbound
= upperbound
= 0;
1831 idx
= value_as_long (value_pos_atr (ind
[i
]));
1832 if (idx
< lowerbound
|| idx
> upperbound
)
1833 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1834 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1835 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1836 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1839 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1840 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1842 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1844 if (VALUE_LVAL (arr
) == lval_internalvar
)
1845 VALUE_LVAL (v
) = lval_internalvar_component
;
1847 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1851 /* Non-zero iff TYPE includes negative integer values. */
1854 has_negatives (struct type
*type
)
1856 switch (TYPE_CODE (type
))
1861 return !TYPE_UNSIGNED (type
);
1862 case TYPE_CODE_RANGE
:
1863 return TYPE_LOW_BOUND (type
) < 0;
1868 /* Create a new value of type TYPE from the contents of OBJ starting
1869 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1870 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1871 assigning through the result will set the field fetched from.
1872 VALADDR is ignored unless OBJ is NULL, in which case,
1873 VALADDR+OFFSET must address the start of storage containing the
1874 packed value. The value returned in this case is never an lval.
1875 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1878 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
1879 long offset
, int bit_offset
, int bit_size
,
1883 int src
, /* Index into the source area */
1884 targ
, /* Index into the target area */
1885 srcBitsLeft
, /* Number of source bits left to move */
1886 nsrc
, ntarg
, /* Number of source and target bytes */
1887 unusedLS
, /* Number of bits in next significant
1888 byte of source that are unused */
1889 accumSize
; /* Number of meaningful bits in accum */
1890 unsigned char *bytes
; /* First byte containing data to unpack */
1891 unsigned char *unpacked
;
1892 unsigned long accum
; /* Staging area for bits being transferred */
1894 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1895 /* Transmit bytes from least to most significant; delta is the direction
1896 the indices move. */
1897 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1899 type
= ada_check_typedef (type
);
1903 v
= allocate_value (type
);
1904 bytes
= (unsigned char *) (valaddr
+ offset
);
1906 else if (value_lazy (obj
))
1909 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
1910 bytes
= (unsigned char *) alloca (len
);
1911 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1915 v
= allocate_value (type
);
1916 bytes
= (unsigned char *) value_contents (obj
) + offset
;
1921 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1922 if (VALUE_LVAL (obj
) == lval_internalvar
)
1923 VALUE_LVAL (v
) = lval_internalvar_component
;
1924 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
;
1925 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
1926 set_value_bitsize (v
, bit_size
);
1927 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
1929 VALUE_ADDRESS (v
) += 1;
1930 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
1934 set_value_bitsize (v
, bit_size
);
1935 unpacked
= (unsigned char *) value_contents (v
);
1937 srcBitsLeft
= bit_size
;
1939 ntarg
= TYPE_LENGTH (type
);
1943 memset (unpacked
, 0, TYPE_LENGTH (type
));
1946 else if (BITS_BIG_ENDIAN
)
1949 if (has_negatives (type
)
1950 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1954 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1957 switch (TYPE_CODE (type
))
1959 case TYPE_CODE_ARRAY
:
1960 case TYPE_CODE_UNION
:
1961 case TYPE_CODE_STRUCT
:
1962 /* Non-scalar values must be aligned at a byte boundary... */
1964 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1965 /* ... And are placed at the beginning (most-significant) bytes
1967 targ
= (bit_size
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
- 1;
1971 targ
= TYPE_LENGTH (type
) - 1;
1977 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1980 unusedLS
= bit_offset
;
1983 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1990 /* Mask for removing bits of the next source byte that are not
1991 part of the value. */
1992 unsigned int unusedMSMask
=
1993 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1995 /* Sign-extend bits for this byte. */
1996 unsigned int signMask
= sign
& ~unusedMSMask
;
1998 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1999 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
2000 if (accumSize
>= HOST_CHAR_BIT
)
2002 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2003 accumSize
-= HOST_CHAR_BIT
;
2004 accum
>>= HOST_CHAR_BIT
;
2008 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
2015 accum
|= sign
<< accumSize
;
2016 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
2017 accumSize
-= HOST_CHAR_BIT
;
2018 accum
>>= HOST_CHAR_BIT
;
2026 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2027 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2030 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
2031 int src_offset
, int n
)
2033 unsigned int accum
, mask
;
2034 int accum_bits
, chunk_size
;
2036 target
+= targ_offset
/ HOST_CHAR_BIT
;
2037 targ_offset
%= HOST_CHAR_BIT
;
2038 source
+= src_offset
/ HOST_CHAR_BIT
;
2039 src_offset
%= HOST_CHAR_BIT
;
2040 if (BITS_BIG_ENDIAN
)
2042 accum
= (unsigned char) *source
;
2044 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2049 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2050 accum_bits
+= HOST_CHAR_BIT
;
2052 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2055 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2056 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2059 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2061 accum_bits
-= chunk_size
;
2068 accum
= (unsigned char) *source
>> src_offset
;
2070 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2074 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2075 accum_bits
+= HOST_CHAR_BIT
;
2077 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2080 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2081 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2083 accum_bits
-= chunk_size
;
2084 accum
>>= chunk_size
;
2091 /* Store the contents of FROMVAL into the location of TOVAL.
2092 Return a new value with the location of TOVAL and contents of
2093 FROMVAL. Handles assignment into packed fields that have
2094 floating-point or non-scalar types. */
2096 static struct value
*
2097 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2099 struct type
*type
= value_type (toval
);
2100 int bits
= value_bitsize (toval
);
2102 if (!deprecated_value_modifiable (toval
))
2103 error (_("Left operand of assignment is not a modifiable lvalue."));
2105 toval
= coerce_ref (toval
);
2107 if (VALUE_LVAL (toval
) == lval_memory
2109 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2110 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2112 int len
= (value_bitpos (toval
)
2113 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2114 char *buffer
= (char *) alloca (len
);
2117 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2118 fromval
= value_cast (type
, fromval
);
2120 read_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
, len
);
2121 if (BITS_BIG_ENDIAN
)
2122 move_bits (buffer
, value_bitpos (toval
),
2123 value_contents (fromval
),
2124 TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
-
2127 move_bits (buffer
, value_bitpos (toval
), value_contents (fromval
),
2129 write_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
,
2132 val
= value_copy (toval
);
2133 memcpy (value_contents_raw (val
), value_contents (fromval
),
2134 TYPE_LENGTH (type
));
2135 deprecated_set_value_type (val
, type
);
2140 return value_assign (toval
, fromval
);
2144 /* The value of the element of array ARR at the ARITY indices given in IND.
2145 ARR may be either a simple array, GNAT array descriptor, or pointer
2149 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2153 struct type
*elt_type
;
2155 elt
= ada_coerce_to_simple_array (arr
);
2157 elt_type
= ada_check_typedef (value_type (elt
));
2158 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2159 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2160 return value_subscript_packed (elt
, arity
, ind
);
2162 for (k
= 0; k
< arity
; k
+= 1)
2164 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2165 error (_("too many subscripts (%d expected)"), k
);
2166 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2171 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2172 value of the element of *ARR at the ARITY indices given in
2173 IND. Does not read the entire array into memory. */
2176 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2181 for (k
= 0; k
< arity
; k
+= 1)
2186 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2187 error (_("too many subscripts (%d expected)"), k
);
2188 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2190 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2191 idx
= value_pos_atr (ind
[k
]);
2193 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2194 arr
= value_add (arr
, idx
);
2195 type
= TYPE_TARGET_TYPE (type
);
2198 return value_ind (arr
);
2201 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2202 actual type of ARRAY_PTR is ignored), returns a reference to
2203 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2204 bound of this array is LOW, as per Ada rules. */
2205 static struct value
*
2206 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2209 CORE_ADDR base
= value_as_address (array_ptr
)
2210 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2211 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2212 struct type
*index_type
=
2213 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2215 struct type
*slice_type
=
2216 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2217 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2221 static struct value
*
2222 ada_value_slice (struct value
*array
, int low
, int high
)
2224 struct type
*type
= value_type (array
);
2225 struct type
*index_type
=
2226 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2227 struct type
*slice_type
=
2228 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2229 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2232 /* If type is a record type in the form of a standard GNAT array
2233 descriptor, returns the number of dimensions for type. If arr is a
2234 simple array, returns the number of "array of"s that prefix its
2235 type designation. Otherwise, returns 0. */
2238 ada_array_arity (struct type
*type
)
2245 type
= desc_base_type (type
);
2248 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2249 return desc_arity (desc_bounds_type (type
));
2251 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2254 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2260 /* If TYPE is a record type in the form of a standard GNAT array
2261 descriptor or a simple array type, returns the element type for
2262 TYPE after indexing by NINDICES indices, or by all indices if
2263 NINDICES is -1. Otherwise, returns NULL. */
2266 ada_array_element_type (struct type
*type
, int nindices
)
2268 type
= desc_base_type (type
);
2270 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2273 struct type
*p_array_type
;
2275 p_array_type
= desc_data_type (type
);
2277 k
= ada_array_arity (type
);
2281 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2282 if (nindices
>= 0 && k
> nindices
)
2284 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2285 while (k
> 0 && p_array_type
!= NULL
)
2287 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2290 return p_array_type
;
2292 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2294 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2296 type
= TYPE_TARGET_TYPE (type
);
2305 /* The type of nth index in arrays of given type (n numbering from 1).
2306 Does not examine memory. */
2309 ada_index_type (struct type
*type
, int n
)
2311 struct type
*result_type
;
2313 type
= desc_base_type (type
);
2315 if (n
> ada_array_arity (type
))
2318 if (ada_is_simple_array_type (type
))
2322 for (i
= 1; i
< n
; i
+= 1)
2323 type
= TYPE_TARGET_TYPE (type
);
2324 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2325 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2326 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2327 perhaps stabsread.c would make more sense. */
2328 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2329 result_type
= builtin_type_int
;
2334 return desc_index_type (desc_bounds_type (type
), n
);
2337 /* Given that arr is an array type, returns the lower bound of the
2338 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2339 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2340 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2341 bounds type. It works for other arrays with bounds supplied by
2342 run-time quantities other than discriminants. */
2345 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2346 struct type
** typep
)
2349 struct type
*index_type_desc
;
2351 if (ada_is_packed_array_type (arr_type
))
2352 arr_type
= decode_packed_array_type (arr_type
);
2354 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2357 *typep
= builtin_type_int
;
2358 return (LONGEST
) - which
;
2361 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2362 type
= TYPE_TARGET_TYPE (arr_type
);
2366 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2367 if (index_type_desc
== NULL
)
2369 struct type
*range_type
;
2370 struct type
*index_type
;
2374 type
= TYPE_TARGET_TYPE (type
);
2378 range_type
= TYPE_INDEX_TYPE (type
);
2379 index_type
= TYPE_TARGET_TYPE (range_type
);
2380 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2381 index_type
= builtin_type_long
;
2383 *typep
= index_type
;
2385 (LONGEST
) (which
== 0
2386 ? TYPE_LOW_BOUND (range_type
)
2387 : TYPE_HIGH_BOUND (range_type
));
2391 struct type
*index_type
=
2392 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2393 NULL
, TYPE_OBJFILE (arr_type
));
2395 *typep
= TYPE_TARGET_TYPE (index_type
);
2397 (LONGEST
) (which
== 0
2398 ? TYPE_LOW_BOUND (index_type
)
2399 : TYPE_HIGH_BOUND (index_type
));
2403 /* Given that arr is an array value, returns the lower bound of the
2404 nth index (numbering from 1) if which is 0, and the upper bound if
2405 which is 1. This routine will also work for arrays with bounds
2406 supplied by run-time quantities other than discriminants. */
2409 ada_array_bound (struct value
*arr
, int n
, int which
)
2411 struct type
*arr_type
= value_type (arr
);
2413 if (ada_is_packed_array_type (arr_type
))
2414 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2415 else if (ada_is_simple_array_type (arr_type
))
2418 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2419 return value_from_longest (type
, v
);
2422 return desc_one_bound (desc_bounds (arr
), n
, which
);
2425 /* Given that arr is an array value, returns the length of the
2426 nth index. This routine will also work for arrays with bounds
2427 supplied by run-time quantities other than discriminants.
2428 Does not work for arrays indexed by enumeration types with representation
2429 clauses at the moment. */
2432 ada_array_length (struct value
*arr
, int n
)
2434 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2436 if (ada_is_packed_array_type (arr_type
))
2437 return ada_array_length (decode_packed_array (arr
), n
);
2439 if (ada_is_simple_array_type (arr_type
))
2443 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2444 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2445 return value_from_longest (type
, v
);
2449 value_from_longest (builtin_type_int
,
2450 value_as_long (desc_one_bound (desc_bounds (arr
),
2452 - value_as_long (desc_one_bound (desc_bounds (arr
),
2456 /* An empty array whose type is that of ARR_TYPE (an array type),
2457 with bounds LOW to LOW-1. */
2459 static struct value
*
2460 empty_array (struct type
*arr_type
, int low
)
2462 struct type
*index_type
=
2463 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2465 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2466 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2470 /* Name resolution */
2472 /* The "decoded" name for the user-definable Ada operator corresponding
2476 ada_decoded_op_name (enum exp_opcode op
)
2480 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2482 if (ada_opname_table
[i
].op
== op
)
2483 return ada_opname_table
[i
].decoded
;
2485 error (_("Could not find operator name for opcode"));
2489 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2490 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2491 undefined namespace) and converts operators that are
2492 user-defined into appropriate function calls. If CONTEXT_TYPE is
2493 non-null, it provides a preferred result type [at the moment, only
2494 type void has any effect---causing procedures to be preferred over
2495 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2496 return type is preferred. May change (expand) *EXP. */
2499 resolve (struct expression
**expp
, int void_context_p
)
2503 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2506 /* Resolve the operator of the subexpression beginning at
2507 position *POS of *EXPP. "Resolving" consists of replacing
2508 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2509 with their resolutions, replacing built-in operators with
2510 function calls to user-defined operators, where appropriate, and,
2511 when DEPROCEDURE_P is non-zero, converting function-valued variables
2512 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2513 are as in ada_resolve, above. */
2515 static struct value
*
2516 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2517 struct type
*context_type
)
2521 struct expression
*exp
; /* Convenience: == *expp. */
2522 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2523 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2524 int nargs
; /* Number of operands. */
2530 /* Pass one: resolve operands, saving their types and updating *pos. */
2534 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2535 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2540 resolve_subexp (expp
, pos
, 0, NULL
);
2542 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2547 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2552 resolve_subexp (expp
, pos
, 0, NULL
);
2555 case OP_ATR_MODULUS
:
2585 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2587 resolve_subexp (expp
, pos
, 1, NULL
);
2589 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2607 case BINOP_LOGICAL_AND
:
2608 case BINOP_LOGICAL_OR
:
2609 case BINOP_BITWISE_AND
:
2610 case BINOP_BITWISE_IOR
:
2611 case BINOP_BITWISE_XOR
:
2614 case BINOP_NOTEQUAL
:
2621 case BINOP_SUBSCRIPT
:
2629 case UNOP_LOGICAL_NOT
:
2646 case OP_INTERNALVAR
:
2655 case STRUCTOP_STRUCT
:
2656 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2662 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2667 case TERNOP_IN_RANGE
:
2672 case BINOP_IN_BOUNDS
:
2678 error (_("Unexpected operator during name resolution"));
2681 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2682 for (i
= 0; i
< nargs
; i
+= 1)
2683 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2687 /* Pass two: perform any resolution on principal operator. */
2694 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2696 struct ada_symbol_info
*candidates
;
2700 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2701 (exp
->elts
[pc
+ 2].symbol
),
2702 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2705 if (n_candidates
> 1)
2707 /* Types tend to get re-introduced locally, so if there
2708 are any local symbols that are not types, first filter
2711 for (j
= 0; j
< n_candidates
; j
+= 1)
2712 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2718 case LOC_REGPARM_ADDR
:
2722 case LOC_BASEREG_ARG
:
2724 case LOC_COMPUTED_ARG
:
2730 if (j
< n_candidates
)
2733 while (j
< n_candidates
)
2735 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2737 candidates
[j
] = candidates
[n_candidates
- 1];
2746 if (n_candidates
== 0)
2747 error (_("No definition found for %s"),
2748 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2749 else if (n_candidates
== 1)
2751 else if (deprocedure_p
2752 && !is_nonfunction (candidates
, n_candidates
))
2754 i
= ada_resolve_function
2755 (candidates
, n_candidates
, NULL
, 0,
2756 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2759 error (_("Could not find a match for %s"),
2760 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2764 printf_filtered (_("Multiple matches for %s\n"),
2765 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2766 user_select_syms (candidates
, n_candidates
, 1);
2770 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2771 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2772 if (innermost_block
== NULL
2773 || contained_in (candidates
[i
].block
, innermost_block
))
2774 innermost_block
= candidates
[i
].block
;
2778 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2781 replace_operator_with_call (expp
, pc
, 0, 0,
2782 exp
->elts
[pc
+ 2].symbol
,
2783 exp
->elts
[pc
+ 1].block
);
2790 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2791 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2793 struct ada_symbol_info
*candidates
;
2797 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2798 (exp
->elts
[pc
+ 5].symbol
),
2799 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2801 if (n_candidates
== 1)
2805 i
= ada_resolve_function
2806 (candidates
, n_candidates
,
2808 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2811 error (_("Could not find a match for %s"),
2812 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2815 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2816 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2817 if (innermost_block
== NULL
2818 || contained_in (candidates
[i
].block
, innermost_block
))
2819 innermost_block
= candidates
[i
].block
;
2830 case BINOP_BITWISE_AND
:
2831 case BINOP_BITWISE_IOR
:
2832 case BINOP_BITWISE_XOR
:
2834 case BINOP_NOTEQUAL
:
2842 case UNOP_LOGICAL_NOT
:
2844 if (possible_user_operator_p (op
, argvec
))
2846 struct ada_symbol_info
*candidates
;
2850 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2851 (struct block
*) NULL
, VAR_DOMAIN
,
2853 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2854 ada_decoded_op_name (op
), NULL
);
2858 replace_operator_with_call (expp
, pc
, nargs
, 1,
2859 candidates
[i
].sym
, candidates
[i
].block
);
2869 return evaluate_subexp_type (exp
, pos
);
2872 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2873 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2874 a non-pointer. A type of 'void' (which is never a valid expression type)
2875 by convention matches anything. */
2876 /* The term "match" here is rather loose. The match is heuristic and
2877 liberal. FIXME: TOO liberal, in fact. */
2880 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2882 ftype
= ada_check_typedef (ftype
);
2883 atype
= ada_check_typedef (atype
);
2885 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2886 ftype
= TYPE_TARGET_TYPE (ftype
);
2887 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2888 atype
= TYPE_TARGET_TYPE (atype
);
2890 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2891 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2894 switch (TYPE_CODE (ftype
))
2899 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2900 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2901 TYPE_TARGET_TYPE (atype
), 0);
2904 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2906 case TYPE_CODE_ENUM
:
2907 case TYPE_CODE_RANGE
:
2908 switch (TYPE_CODE (atype
))
2911 case TYPE_CODE_ENUM
:
2912 case TYPE_CODE_RANGE
:
2918 case TYPE_CODE_ARRAY
:
2919 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2920 || ada_is_array_descriptor_type (atype
));
2922 case TYPE_CODE_STRUCT
:
2923 if (ada_is_array_descriptor_type (ftype
))
2924 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2925 || ada_is_array_descriptor_type (atype
));
2927 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2928 && !ada_is_array_descriptor_type (atype
));
2930 case TYPE_CODE_UNION
:
2932 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2936 /* Return non-zero if the formals of FUNC "sufficiently match" the
2937 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2938 may also be an enumeral, in which case it is treated as a 0-
2939 argument function. */
2942 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2945 struct type
*func_type
= SYMBOL_TYPE (func
);
2947 if (SYMBOL_CLASS (func
) == LOC_CONST
2948 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2949 return (n_actuals
== 0);
2950 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2953 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2956 for (i
= 0; i
< n_actuals
; i
+= 1)
2958 if (actuals
[i
] == NULL
)
2962 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2963 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
2965 if (!ada_type_match (ftype
, atype
, 1))
2972 /* False iff function type FUNC_TYPE definitely does not produce a value
2973 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2974 FUNC_TYPE is not a valid function type with a non-null return type
2975 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2978 return_match (struct type
*func_type
, struct type
*context_type
)
2980 struct type
*return_type
;
2982 if (func_type
== NULL
)
2985 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2986 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2988 return_type
= base_type (func_type
);
2989 if (return_type
== NULL
)
2992 context_type
= base_type (context_type
);
2994 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2995 return context_type
== NULL
|| return_type
== context_type
;
2996 else if (context_type
== NULL
)
2997 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2999 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
3003 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3004 function (if any) that matches the types of the NARGS arguments in
3005 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3006 that returns that type, then eliminate matches that don't. If
3007 CONTEXT_TYPE is void and there is at least one match that does not
3008 return void, eliminate all matches that do.
3010 Asks the user if there is more than one match remaining. Returns -1
3011 if there is no such symbol or none is selected. NAME is used
3012 solely for messages. May re-arrange and modify SYMS in
3013 the process; the index returned is for the modified vector. */
3016 ada_resolve_function (struct ada_symbol_info syms
[],
3017 int nsyms
, struct value
**args
, int nargs
,
3018 const char *name
, struct type
*context_type
)
3021 int m
; /* Number of hits */
3022 struct type
*fallback
;
3023 struct type
*return_type
;
3025 return_type
= context_type
;
3026 if (context_type
== NULL
)
3027 fallback
= builtin_type_void
;
3034 for (k
= 0; k
< nsyms
; k
+= 1)
3036 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3038 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3039 && return_match (type
, return_type
))
3045 if (m
> 0 || return_type
== fallback
)
3048 return_type
= fallback
;
3055 printf_filtered (_("Multiple matches for %s\n"), name
);
3056 user_select_syms (syms
, m
, 1);
3062 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3063 in a listing of choices during disambiguation (see sort_choices, below).
3064 The idea is that overloadings of a subprogram name from the
3065 same package should sort in their source order. We settle for ordering
3066 such symbols by their trailing number (__N or $N). */
3069 encoded_ordered_before (char *N0
, char *N1
)
3073 else if (N0
== NULL
)
3078 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3080 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3082 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3083 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3087 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3090 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3092 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3093 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3095 return (strcmp (N0
, N1
) < 0);
3099 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3103 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3106 for (i
= 1; i
< nsyms
; i
+= 1)
3108 struct ada_symbol_info sym
= syms
[i
];
3111 for (j
= i
- 1; j
>= 0; j
-= 1)
3113 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3114 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3116 syms
[j
+ 1] = syms
[j
];
3122 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3123 by asking the user (if necessary), returning the number selected,
3124 and setting the first elements of SYMS items. Error if no symbols
3127 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3128 to be re-integrated one of these days. */
3131 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3134 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3136 int first_choice
= (max_results
== 1) ? 1 : 2;
3138 if (max_results
< 1)
3139 error (_("Request to select 0 symbols!"));
3143 printf_unfiltered (_("[0] cancel\n"));
3144 if (max_results
> 1)
3145 printf_unfiltered (_("[1] all\n"));
3147 sort_choices (syms
, nsyms
);
3149 for (i
= 0; i
< nsyms
; i
+= 1)
3151 if (syms
[i
].sym
== NULL
)
3154 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3156 struct symtab_and_line sal
=
3157 find_function_start_sal (syms
[i
].sym
, 1);
3158 if (sal
.symtab
== NULL
)
3159 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3161 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3164 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3165 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3166 sal
.symtab
->filename
, sal
.line
);
3172 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3173 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3174 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3175 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3177 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3178 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3180 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3181 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3182 else if (is_enumeral
3183 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3185 printf_unfiltered (("[%d] "), i
+ first_choice
);
3186 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3188 printf_unfiltered (_("'(%s) (enumeral)\n"),
3189 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3191 else if (symtab
!= NULL
)
3192 printf_unfiltered (is_enumeral
3193 ? _("[%d] %s in %s (enumeral)\n")
3194 : _("[%d] %s at %s:?\n"),
3196 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3199 printf_unfiltered (is_enumeral
3200 ? _("[%d] %s (enumeral)\n")
3201 : _("[%d] %s at ?\n"),
3203 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3207 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3210 for (i
= 0; i
< n_chosen
; i
+= 1)
3211 syms
[i
] = syms
[chosen
[i
]];
3216 /* Read and validate a set of numeric choices from the user in the
3217 range 0 .. N_CHOICES-1. Place the results in increasing
3218 order in CHOICES[0 .. N-1], and return N.
3220 The user types choices as a sequence of numbers on one line
3221 separated by blanks, encoding them as follows:
3223 + A choice of 0 means to cancel the selection, throwing an error.
3224 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3225 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3227 The user is not allowed to choose more than MAX_RESULTS values.
3229 ANNOTATION_SUFFIX, if present, is used to annotate the input
3230 prompts (for use with the -f switch). */
3233 get_selections (int *choices
, int n_choices
, int max_results
,
3234 int is_all_choice
, char *annotation_suffix
)
3239 int first_choice
= is_all_choice
? 2 : 1;
3241 prompt
= getenv ("PS2");
3245 printf_unfiltered (("%s "), prompt
);
3246 gdb_flush (gdb_stdout
);
3248 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3251 error_no_arg (_("one or more choice numbers"));
3255 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3256 order, as given in args. Choices are validated. */
3262 while (isspace (*args
))
3264 if (*args
== '\0' && n_chosen
== 0)
3265 error_no_arg (_("one or more choice numbers"));
3266 else if (*args
== '\0')
3269 choice
= strtol (args
, &args2
, 10);
3270 if (args
== args2
|| choice
< 0
3271 || choice
> n_choices
+ first_choice
- 1)
3272 error (_("Argument must be choice number"));
3276 error (_("cancelled"));
3278 if (choice
< first_choice
)
3280 n_chosen
= n_choices
;
3281 for (j
= 0; j
< n_choices
; j
+= 1)
3285 choice
-= first_choice
;
3287 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3291 if (j
< 0 || choice
!= choices
[j
])
3294 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3295 choices
[k
+ 1] = choices
[k
];
3296 choices
[j
+ 1] = choice
;
3301 if (n_chosen
> max_results
)
3302 error (_("Select no more than %d of the above"), max_results
);
3307 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3308 on the function identified by SYM and BLOCK, and taking NARGS
3309 arguments. Update *EXPP as needed to hold more space. */
3312 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3313 int oplen
, struct symbol
*sym
,
3314 struct block
*block
)
3316 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3317 symbol, -oplen for operator being replaced). */
3318 struct expression
*newexp
= (struct expression
*)
3319 xmalloc (sizeof (struct expression
)
3320 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3321 struct expression
*exp
= *expp
;
3323 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3324 newexp
->language_defn
= exp
->language_defn
;
3325 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3326 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3327 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3329 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3330 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3332 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3333 newexp
->elts
[pc
+ 4].block
= block
;
3334 newexp
->elts
[pc
+ 5].symbol
= sym
;
3340 /* Type-class predicates */
3342 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3346 numeric_type_p (struct type
*type
)
3352 switch (TYPE_CODE (type
))
3357 case TYPE_CODE_RANGE
:
3358 return (type
== TYPE_TARGET_TYPE (type
)
3359 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3366 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3369 integer_type_p (struct type
*type
)
3375 switch (TYPE_CODE (type
))
3379 case TYPE_CODE_RANGE
:
3380 return (type
== TYPE_TARGET_TYPE (type
)
3381 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3388 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3391 scalar_type_p (struct type
*type
)
3397 switch (TYPE_CODE (type
))
3400 case TYPE_CODE_RANGE
:
3401 case TYPE_CODE_ENUM
:
3410 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3413 discrete_type_p (struct type
*type
)
3419 switch (TYPE_CODE (type
))
3422 case TYPE_CODE_RANGE
:
3423 case TYPE_CODE_ENUM
:
3431 /* Returns non-zero if OP with operands in the vector ARGS could be
3432 a user-defined function. Errs on the side of pre-defined operators
3433 (i.e., result 0). */
3436 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3438 struct type
*type0
=
3439 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3440 struct type
*type1
=
3441 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3455 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3459 case BINOP_BITWISE_AND
:
3460 case BINOP_BITWISE_IOR
:
3461 case BINOP_BITWISE_XOR
:
3462 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3465 case BINOP_NOTEQUAL
:
3470 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3474 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3475 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3476 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3477 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3478 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3479 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
))
3480 != TYPE_CODE_ARRAY
))));
3483 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3487 case UNOP_LOGICAL_NOT
:
3489 return (!numeric_type_p (type0
));
3496 /* NOTE: In the following, we assume that a renaming type's name may
3497 have an ___XD suffix. It would be nice if this went away at some
3500 /* If TYPE encodes a renaming, returns the renaming suffix, which
3501 is XR for an object renaming, XRP for a procedure renaming, XRE for
3502 an exception renaming, and XRS for a subprogram renaming. Returns
3503 NULL if NAME encodes none of these. */
3506 ada_renaming_type (struct type
*type
)
3508 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3510 const char *name
= type_name_no_tag (type
);
3511 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3513 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3522 /* Return non-zero iff SYM encodes an object renaming. */
3525 ada_is_object_renaming (struct symbol
*sym
)
3527 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3528 return renaming_type
!= NULL
3529 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3532 /* Assuming that SYM encodes a non-object renaming, returns the original
3533 name of the renamed entity. The name is good until the end of
3537 ada_simple_renamed_entity (struct symbol
*sym
)
3540 const char *raw_name
;
3544 type
= SYMBOL_TYPE (sym
);
3545 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3546 error (_("Improperly encoded renaming."));
3548 raw_name
= TYPE_FIELD_NAME (type
, 0);
3549 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3551 error (_("Improperly encoded renaming."));
3553 result
= xmalloc (len
+ 1);
3554 strncpy (result
, raw_name
, len
);
3555 result
[len
] = '\000';
3560 /* Evaluation: Function Calls */
3562 /* Return an lvalue containing the value VAL. This is the identity on
3563 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3564 on the stack, using and updating *SP as the stack pointer, and
3565 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3567 static struct value
*
3568 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3570 if (! VALUE_LVAL (val
))
3572 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3574 /* The following is taken from the structure-return code in
3575 call_function_by_hand. FIXME: Therefore, some refactoring seems
3577 if (INNER_THAN (1, 2))
3579 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3580 reserving sufficient space. */
3582 if (gdbarch_frame_align_p (current_gdbarch
))
3583 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3584 VALUE_ADDRESS (val
) = *sp
;
3588 /* Stack grows upward. Align the frame, allocate space, and
3589 then again, re-align the frame. */
3590 if (gdbarch_frame_align_p (current_gdbarch
))
3591 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3592 VALUE_ADDRESS (val
) = *sp
;
3594 if (gdbarch_frame_align_p (current_gdbarch
))
3595 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3598 write_memory (VALUE_ADDRESS (val
), value_contents_raw (val
), len
);
3604 /* Return the value ACTUAL, converted to be an appropriate value for a
3605 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3606 allocating any necessary descriptors (fat pointers), or copies of
3607 values not residing in memory, updating it as needed. */
3609 static struct value
*
3610 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3613 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3614 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3615 struct type
*formal_target
=
3616 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3617 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3618 struct type
*actual_target
=
3619 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3620 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3622 if (ada_is_array_descriptor_type (formal_target
)
3623 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3624 return make_array_descriptor (formal_type
, actual
, sp
);
3625 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3627 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3628 && ada_is_array_descriptor_type (actual_target
))
3629 return desc_data (actual
);
3630 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3632 if (VALUE_LVAL (actual
) != lval_memory
)
3635 actual_type
= ada_check_typedef (value_type (actual
));
3636 val
= allocate_value (actual_type
);
3637 memcpy ((char *) value_contents_raw (val
),
3638 (char *) value_contents (actual
),
3639 TYPE_LENGTH (actual_type
));
3640 actual
= ensure_lval (val
, sp
);
3642 return value_addr (actual
);
3645 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3646 return ada_value_ind (actual
);
3652 /* Push a descriptor of type TYPE for array value ARR on the stack at
3653 *SP, updating *SP to reflect the new descriptor. Return either
3654 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3655 to-descriptor type rather than a descriptor type), a struct value *
3656 representing a pointer to this descriptor. */
3658 static struct value
*
3659 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3661 struct type
*bounds_type
= desc_bounds_type (type
);
3662 struct type
*desc_type
= desc_base_type (type
);
3663 struct value
*descriptor
= allocate_value (desc_type
);
3664 struct value
*bounds
= allocate_value (bounds_type
);
3667 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3669 modify_general_field (value_contents_writeable (bounds
),
3670 value_as_long (ada_array_bound (arr
, i
, 0)),
3671 desc_bound_bitpos (bounds_type
, i
, 0),
3672 desc_bound_bitsize (bounds_type
, i
, 0));
3673 modify_general_field (value_contents_writeable (bounds
),
3674 value_as_long (ada_array_bound (arr
, i
, 1)),
3675 desc_bound_bitpos (bounds_type
, i
, 1),
3676 desc_bound_bitsize (bounds_type
, i
, 1));
3679 bounds
= ensure_lval (bounds
, sp
);
3681 modify_general_field (value_contents_writeable (descriptor
),
3682 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3683 fat_pntr_data_bitpos (desc_type
),
3684 fat_pntr_data_bitsize (desc_type
));
3686 modify_general_field (value_contents_writeable (descriptor
),
3687 VALUE_ADDRESS (bounds
),
3688 fat_pntr_bounds_bitpos (desc_type
),
3689 fat_pntr_bounds_bitsize (desc_type
));
3691 descriptor
= ensure_lval (descriptor
, sp
);
3693 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3694 return value_addr (descriptor
);
3700 /* Assuming a dummy frame has been established on the target, perform any
3701 conversions needed for calling function FUNC on the NARGS actual
3702 parameters in ARGS, other than standard C conversions. Does
3703 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3704 does not match the number of arguments expected. Use *SP as a
3705 stack pointer for additional data that must be pushed, updating its
3709 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3714 if (TYPE_NFIELDS (value_type (func
)) == 0
3715 || nargs
!= TYPE_NFIELDS (value_type (func
)))
3718 for (i
= 0; i
< nargs
; i
+= 1)
3720 convert_actual (args
[i
], TYPE_FIELD_TYPE (value_type (func
), i
), sp
);
3723 /* Dummy definitions for an experimental caching module that is not
3724 * used in the public sources. */
3727 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3728 struct symbol
**sym
, struct block
**block
,
3729 struct symtab
**symtab
)
3735 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3736 struct block
*block
, struct symtab
*symtab
)
3742 /* Return the result of a standard (literal, C-like) lookup of NAME in
3743 given DOMAIN, visible from lexical block BLOCK. */
3745 static struct symbol
*
3746 standard_lookup (const char *name
, const struct block
*block
,
3750 struct symtab
*symtab
;
3752 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3755 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3756 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3761 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3762 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3763 since they contend in overloading in the same way. */
3765 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3769 for (i
= 0; i
< n
; i
+= 1)
3770 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3771 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3772 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3778 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3779 struct types. Otherwise, they may not. */
3782 equiv_types (struct type
*type0
, struct type
*type1
)
3786 if (type0
== NULL
|| type1
== NULL
3787 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3789 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3790 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3791 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3792 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3798 /* True iff SYM0 represents the same entity as SYM1, or one that is
3799 no more defined than that of SYM1. */
3802 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3806 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3807 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3810 switch (SYMBOL_CLASS (sym0
))
3816 struct type
*type0
= SYMBOL_TYPE (sym0
);
3817 struct type
*type1
= SYMBOL_TYPE (sym1
);
3818 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3819 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3820 int len0
= strlen (name0
);
3822 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3823 && (equiv_types (type0
, type1
)
3824 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3825 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3828 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3829 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3835 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3836 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3839 add_defn_to_vec (struct obstack
*obstackp
,
3841 struct block
*block
, struct symtab
*symtab
)
3845 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3847 /* Do not try to complete stub types, as the debugger is probably
3848 already scanning all symbols matching a certain name at the
3849 time when this function is called. Trying to replace the stub
3850 type by its associated full type will cause us to restart a scan
3851 which may lead to an infinite recursion. Instead, the client
3852 collecting the matching symbols will end up collecting several
3853 matches, with at least one of them complete. It can then filter
3854 out the stub ones if needed. */
3856 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3858 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3860 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3862 prevDefns
[i
].sym
= sym
;
3863 prevDefns
[i
].block
= block
;
3864 prevDefns
[i
].symtab
= symtab
;
3870 struct ada_symbol_info info
;
3874 info
.symtab
= symtab
;
3875 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3879 /* Number of ada_symbol_info structures currently collected in
3880 current vector in *OBSTACKP. */
3883 num_defns_collected (struct obstack
*obstackp
)
3885 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3888 /* Vector of ada_symbol_info structures currently collected in current
3889 vector in *OBSTACKP. If FINISH, close off the vector and return
3890 its final address. */
3892 static struct ada_symbol_info
*
3893 defns_collected (struct obstack
*obstackp
, int finish
)
3896 return obstack_finish (obstackp
);
3898 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3901 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3902 Check the global symbols if GLOBAL, the static symbols if not.
3903 Do wild-card match if WILD. */
3905 static struct partial_symbol
*
3906 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3907 int global
, domain_enum
namespace, int wild
)
3909 struct partial_symbol
**start
;
3910 int name_len
= strlen (name
);
3911 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3920 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3921 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3925 for (i
= 0; i
< length
; i
+= 1)
3927 struct partial_symbol
*psym
= start
[i
];
3929 if (SYMBOL_DOMAIN (psym
) == namespace
3930 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3944 int M
= (U
+ i
) >> 1;
3945 struct partial_symbol
*psym
= start
[M
];
3946 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3948 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3950 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
3961 struct partial_symbol
*psym
= start
[i
];
3963 if (SYMBOL_DOMAIN (psym
) == namespace)
3965 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
3973 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3987 int M
= (U
+ i
) >> 1;
3988 struct partial_symbol
*psym
= start
[M
];
3989 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
3991 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
3993 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4004 struct partial_symbol
*psym
= start
[i
];
4006 if (SYMBOL_DOMAIN (psym
) == namespace)
4010 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4013 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4015 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4025 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4035 /* Find a symbol table containing symbol SYM or NULL if none. */
4037 static struct symtab
*
4038 symtab_for_sym (struct symbol
*sym
)
4041 struct objfile
*objfile
;
4043 struct symbol
*tmp_sym
;
4044 struct dict_iterator iter
;
4047 ALL_SYMTABS (objfile
, s
)
4049 switch (SYMBOL_CLASS (sym
))
4057 case LOC_CONST_BYTES
:
4058 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4059 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4061 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4062 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4068 switch (SYMBOL_CLASS (sym
))
4074 case LOC_REGPARM_ADDR
:
4079 case LOC_BASEREG_ARG
:
4081 case LOC_COMPUTED_ARG
:
4082 for (j
= FIRST_LOCAL_BLOCK
;
4083 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4085 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4086 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4097 /* Return a minimal symbol matching NAME according to Ada decoding
4098 rules. Returns NULL if there is no such minimal symbol. Names
4099 prefixed with "standard__" are handled specially: "standard__" is
4100 first stripped off, and only static and global symbols are searched. */
4102 struct minimal_symbol
*
4103 ada_lookup_simple_minsym (const char *name
)
4105 struct objfile
*objfile
;
4106 struct minimal_symbol
*msymbol
;
4109 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4111 name
+= sizeof ("standard__") - 1;
4115 wild_match
= (strstr (name
, "__") == NULL
);
4117 ALL_MSYMBOLS (objfile
, msymbol
)
4119 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4120 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4127 /* For all subprograms that statically enclose the subprogram of the
4128 selected frame, add symbols matching identifier NAME in DOMAIN
4129 and their blocks to the list of data in OBSTACKP, as for
4130 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4134 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4135 const char *name
, domain_enum
namespace,
4140 /* FIXME: The next two routines belong in symtab.c */
4143 restore_language (void *lang
)
4145 set_language ((enum language
) lang
);
4148 /* As for lookup_symbol, but performed as if the current language
4152 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4153 domain_enum domain
, enum language lang
,
4154 int *is_a_field_of_this
, struct symtab
**symtab
)
4156 struct cleanup
*old_chain
4157 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4158 struct symbol
*result
;
4159 set_language (lang
);
4160 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4161 do_cleanups (old_chain
);
4165 /* True if TYPE is definitely an artificial type supplied to a symbol
4166 for which no debugging information was given in the symbol file. */
4169 is_nondebugging_type (struct type
*type
)
4171 char *name
= ada_type_name (type
);
4172 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4175 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4176 duplicate other symbols in the list (The only case I know of where
4177 this happens is when object files containing stabs-in-ecoff are
4178 linked with files containing ordinary ecoff debugging symbols (or no
4179 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4180 Returns the number of items in the modified list. */
4183 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4190 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4191 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4192 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4194 for (j
= 0; j
< nsyms
; j
+= 1)
4197 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4198 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4199 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4200 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4201 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4202 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4205 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4206 syms
[k
- 1] = syms
[k
];
4219 /* Given a type that corresponds to a renaming entity, use the type name
4220 to extract the scope (package name or function name, fully qualified,
4221 and following the GNAT encoding convention) where this renaming has been
4222 defined. The string returned needs to be deallocated after use. */
4225 xget_renaming_scope (struct type
*renaming_type
)
4227 /* The renaming types adhere to the following convention:
4228 <scope>__<rename>___<XR extension>.
4229 So, to extract the scope, we search for the "___XR" extension,
4230 and then backtrack until we find the first "__". */
4232 const char *name
= type_name_no_tag (renaming_type
);
4233 char *suffix
= strstr (name
, "___XR");
4238 /* Now, backtrack a bit until we find the first "__". Start looking
4239 at suffix - 3, as the <rename> part is at least one character long. */
4241 for (last
= suffix
- 3; last
> name
; last
--)
4242 if (last
[0] == '_' && last
[1] == '_')
4245 /* Make a copy of scope and return it. */
4247 scope_len
= last
- name
;
4248 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4250 strncpy (scope
, name
, scope_len
);
4251 scope
[scope_len
] = '\0';
4256 /* Return nonzero if NAME corresponds to a package name. */
4259 is_package_name (const char *name
)
4261 /* Here, We take advantage of the fact that no symbols are generated
4262 for packages, while symbols are generated for each function.
4263 So the condition for NAME represent a package becomes equivalent
4264 to NAME not existing in our list of symbols. There is only one
4265 small complication with library-level functions (see below). */
4269 /* If it is a function that has not been defined at library level,
4270 then we should be able to look it up in the symbols. */
4271 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4274 /* Library-level function names start with "_ada_". See if function
4275 "_ada_" followed by NAME can be found. */
4277 /* Do a quick check that NAME does not contain "__", since library-level
4278 functions names can not contain "__" in them. */
4279 if (strstr (name
, "__") != NULL
)
4282 fun_name
= xstrprintf ("_ada_%s", name
);
4284 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4287 /* Return nonzero if SYM corresponds to a renaming entity that is
4288 visible from FUNCTION_NAME. */
4291 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4293 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4295 make_cleanup (xfree
, scope
);
4297 /* If the rename has been defined in a package, then it is visible. */
4298 if (is_package_name (scope
))
4301 /* Check that the rename is in the current function scope by checking
4302 that its name starts with SCOPE. */
4304 /* If the function name starts with "_ada_", it means that it is
4305 a library-level function. Strip this prefix before doing the
4306 comparison, as the encoding for the renaming does not contain
4308 if (strncmp (function_name
, "_ada_", 5) == 0)
4311 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4314 /* Iterates over the SYMS list and remove any entry that corresponds to
4315 a renaming entity that is not visible from the function associated
4319 GNAT emits a type following a specified encoding for each renaming
4320 entity. Unfortunately, STABS currently does not support the definition
4321 of types that are local to a given lexical block, so all renamings types
4322 are emitted at library level. As a consequence, if an application
4323 contains two renaming entities using the same name, and a user tries to
4324 print the value of one of these entities, the result of the ada symbol
4325 lookup will also contain the wrong renaming type.
4327 This function partially covers for this limitation by attempting to
4328 remove from the SYMS list renaming symbols that should be visible
4329 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4330 method with the current information available. The implementation
4331 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4333 - When the user tries to print a rename in a function while there
4334 is another rename entity defined in a package: Normally, the
4335 rename in the function has precedence over the rename in the
4336 package, so the latter should be removed from the list. This is
4337 currently not the case.
4339 - This function will incorrectly remove valid renames if
4340 the CURRENT_BLOCK corresponds to a function which symbol name
4341 has been changed by an "Export" pragma. As a consequence,
4342 the user will be unable to print such rename entities. */
4345 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4346 int nsyms
, struct block
*current_block
)
4348 struct symbol
*current_function
;
4349 char *current_function_name
;
4352 /* Extract the function name associated to CURRENT_BLOCK.
4353 Abort if unable to do so. */
4355 if (current_block
== NULL
)
4358 current_function
= block_function (current_block
);
4359 if (current_function
== NULL
)
4362 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4363 if (current_function_name
== NULL
)
4366 /* Check each of the symbols, and remove it from the list if it is
4367 a type corresponding to a renaming that is out of the scope of
4368 the current block. */
4373 if (ada_is_object_renaming (syms
[i
].sym
)
4374 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4377 for (j
= i
+ 1; j
< nsyms
; j
++)
4378 syms
[j
- 1] = syms
[j
];
4388 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4389 scope and in global scopes, returning the number of matches. Sets
4390 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4391 indicating the symbols found and the blocks and symbol tables (if
4392 any) in which they were found. This vector are transient---good only to
4393 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4394 symbol match within the nest of blocks whose innermost member is BLOCK0,
4395 is the one match returned (no other matches in that or
4396 enclosing blocks is returned). If there are any matches in or
4397 surrounding BLOCK0, then these alone are returned. Otherwise, the
4398 search extends to global and file-scope (static) symbol tables.
4399 Names prefixed with "standard__" are handled specially: "standard__"
4400 is first stripped off, and only static and global symbols are searched. */
4403 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4404 domain_enum
namespace,
4405 struct ada_symbol_info
**results
)
4409 struct partial_symtab
*ps
;
4410 struct blockvector
*bv
;
4411 struct objfile
*objfile
;
4412 struct block
*block
;
4414 struct minimal_symbol
*msymbol
;
4420 obstack_free (&symbol_list_obstack
, NULL
);
4421 obstack_init (&symbol_list_obstack
);
4425 /* Search specified block and its superiors. */
4427 wild_match
= (strstr (name0
, "__") == NULL
);
4429 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4430 needed, but adding const will
4431 have a cascade effect. */
4432 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4436 name
= name0
+ sizeof ("standard__") - 1;
4440 while (block
!= NULL
)
4443 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4444 namespace, NULL
, NULL
, wild_match
);
4446 /* If we found a non-function match, assume that's the one. */
4447 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4448 num_defns_collected (&symbol_list_obstack
)))
4451 block
= BLOCK_SUPERBLOCK (block
);
4454 /* If no luck so far, try to find NAME as a local symbol in some lexically
4455 enclosing subprogram. */
4456 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4457 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4458 name
, namespace, wild_match
);
4460 /* If we found ANY matches among non-global symbols, we're done. */
4462 if (num_defns_collected (&symbol_list_obstack
) > 0)
4466 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4469 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4473 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4474 tables, and psymtab's. */
4476 ALL_SYMTABS (objfile
, s
)
4481 bv
= BLOCKVECTOR (s
);
4482 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4483 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4484 objfile
, s
, wild_match
);
4487 if (namespace == VAR_DOMAIN
)
4489 ALL_MSYMBOLS (objfile
, msymbol
)
4491 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4493 switch (MSYMBOL_TYPE (msymbol
))
4495 case mst_solib_trampoline
:
4498 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4501 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4503 bv
= BLOCKVECTOR (s
);
4504 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4505 ada_add_block_symbols (&symbol_list_obstack
, block
,
4506 SYMBOL_LINKAGE_NAME (msymbol
),
4507 namespace, objfile
, s
, wild_match
);
4509 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4511 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4512 ada_add_block_symbols (&symbol_list_obstack
, block
,
4513 SYMBOL_LINKAGE_NAME (msymbol
),
4514 namespace, objfile
, s
,
4523 ALL_PSYMTABS (objfile
, ps
)
4527 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4529 s
= PSYMTAB_TO_SYMTAB (ps
);
4532 bv
= BLOCKVECTOR (s
);
4533 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4534 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4535 namespace, objfile
, s
, wild_match
);
4539 /* Now add symbols from all per-file blocks if we've gotten no hits
4540 (Not strictly correct, but perhaps better than an error).
4541 Do the symtabs first, then check the psymtabs. */
4543 if (num_defns_collected (&symbol_list_obstack
) == 0)
4546 ALL_SYMTABS (objfile
, s
)
4551 bv
= BLOCKVECTOR (s
);
4552 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4553 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4554 objfile
, s
, wild_match
);
4557 ALL_PSYMTABS (objfile
, ps
)
4561 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4563 s
= PSYMTAB_TO_SYMTAB (ps
);
4564 bv
= BLOCKVECTOR (s
);
4567 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4568 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4569 namespace, objfile
, s
, wild_match
);
4575 ndefns
= num_defns_collected (&symbol_list_obstack
);
4576 *results
= defns_collected (&symbol_list_obstack
, 1);
4578 ndefns
= remove_extra_symbols (*results
, ndefns
);
4581 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4583 if (ndefns
== 1 && cacheIfUnique
)
4584 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4585 (*results
)[0].symtab
);
4587 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4588 (struct block
*) block0
);
4593 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4594 scope and in global scopes, or NULL if none. NAME is folded and
4595 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4596 choosing the first symbol if there are multiple choices.
4597 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4598 table in which the symbol was found (in both cases, these
4599 assignments occur only if the pointers are non-null). */
4602 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4603 domain_enum
namespace, int *is_a_field_of_this
,
4604 struct symtab
**symtab
)
4606 struct ada_symbol_info
*candidates
;
4609 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4610 block0
, namespace, &candidates
);
4612 if (n_candidates
== 0)
4615 if (is_a_field_of_this
!= NULL
)
4616 *is_a_field_of_this
= 0;
4620 *symtab
= candidates
[0].symtab
;
4621 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4623 struct objfile
*objfile
;
4626 struct blockvector
*bv
;
4628 /* Search the list of symtabs for one which contains the
4629 address of the start of this block. */
4630 ALL_SYMTABS (objfile
, s
)
4632 bv
= BLOCKVECTOR (s
);
4633 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4634 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4635 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4638 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4641 /* FIXME: brobecker/2004-11-12: I think that we should never
4642 reach this point. I don't see a reason why we would not
4643 find a symtab for a given block, so I suggest raising an
4644 internal_error exception here. Otherwise, we end up
4645 returning a symbol but no symtab, which certain parts of
4646 the code that rely (indirectly) on this function do not
4647 expect, eventually causing a SEGV. */
4648 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4651 return candidates
[0].sym
;
4654 static struct symbol
*
4655 ada_lookup_symbol_nonlocal (const char *name
,
4656 const char *linkage_name
,
4657 const struct block
*block
,
4658 const domain_enum domain
, struct symtab
**symtab
)
4660 if (linkage_name
== NULL
)
4661 linkage_name
= name
;
4662 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4667 /* True iff STR is a possible encoded suffix of a normal Ada name
4668 that is to be ignored for matching purposes. Suffixes of parallel
4669 names (e.g., XVE) are not included here. Currently, the possible suffixes
4670 are given by either of the regular expression:
4672 (__[0-9]+)?[.$][0-9]+ [nested subprogram suffix, on platforms such
4674 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4675 _E[0-9]+[bs]$ [protected object entry suffixes]
4676 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4680 is_name_suffix (const char *str
)
4683 const char *matching
;
4684 const int len
= strlen (str
);
4686 /* (__[0-9]+)?\.[0-9]+ */
4688 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4691 while (isdigit (matching
[0]))
4693 if (matching
[0] == '\0')
4697 if (matching
[0] == '.' || matching
[0] == '$')
4700 while (isdigit (matching
[0]))
4702 if (matching
[0] == '\0')
4707 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4710 while (isdigit (matching
[0]))
4712 if (matching
[0] == '\0')
4717 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
4718 with a N at the end. Unfortunately, the compiler uses the same
4719 convention for other internal types it creates. So treating
4720 all entity names that end with an "N" as a name suffix causes
4721 some regressions. For instance, consider the case of an enumerated
4722 type. To support the 'Image attribute, it creates an array whose
4724 Having a single character like this as a suffix carrying some
4725 information is a bit risky. Perhaps we should change the encoding
4726 to be something like "_N" instead. In the meantime, do not do
4727 the following check. */
4728 /* Protected Object Subprograms */
4729 if (len
== 1 && str
[0] == 'N')
4734 if (len
> 3 && str
[0] == '_' && str
[1] == 'E' && isdigit (str
[2]))
4737 while (isdigit (matching
[0]))
4739 if ((matching
[0] == 'b' || matching
[0] == 's')
4740 && matching
[1] == '\0')
4744 /* ??? We should not modify STR directly, as we are doing below. This
4745 is fine in this case, but may become problematic later if we find
4746 that this alternative did not work, and want to try matching
4747 another one from the begining of STR. Since we modified it, we
4748 won't be able to find the begining of the string anymore! */
4752 while (str
[0] != '_' && str
[0] != '\0')
4754 if (str
[0] != 'n' && str
[0] != 'b')
4759 if (str
[0] == '\000')
4763 if (str
[1] != '_' || str
[2] == '\000')
4767 if (strcmp (str
+ 3, "JM") == 0)
4769 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4770 the LJM suffix in favor of the JM one. But we will
4771 still accept LJM as a valid suffix for a reasonable
4772 amount of time, just to allow ourselves to debug programs
4773 compiled using an older version of GNAT. */
4774 if (strcmp (str
+ 3, "LJM") == 0)
4778 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4779 || str
[4] == 'U' || str
[4] == 'P')
4781 if (str
[4] == 'R' && str
[5] != 'T')
4785 if (!isdigit (str
[2]))
4787 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4788 if (!isdigit (str
[k
]) && str
[k
] != '_')
4792 if (str
[0] == '$' && isdigit (str
[1]))
4794 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4795 if (!isdigit (str
[k
]) && str
[k
] != '_')
4802 /* Return nonzero if the given string starts with a dot ('.')
4803 followed by zero or more digits.
4805 Note: brobecker/2003-11-10: A forward declaration has not been
4806 added at the begining of this file yet, because this function
4807 is only used to work around a problem found during wild matching
4808 when trying to match minimal symbol names against symbol names
4809 obtained from dwarf-2 data. This function is therefore currently
4810 only used in wild_match() and is likely to be deleted when the
4811 problem in dwarf-2 is fixed. */
4814 is_dot_digits_suffix (const char *str
)
4820 while (isdigit (str
[0]))
4822 return (str
[0] == '\0');
4825 /* Return non-zero if NAME0 is a valid match when doing wild matching.
4826 Certain symbols appear at first to match, except that they turn out
4827 not to follow the Ada encoding and hence should not be used as a wild
4828 match of a given pattern. */
4831 is_valid_name_for_wild_match (const char *name0
)
4833 const char *decoded_name
= ada_decode (name0
);
4836 for (i
=0; decoded_name
[i
] != '\0'; i
++)
4837 if (isalpha (decoded_name
[i
]) && !islower (decoded_name
[i
]))
4843 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4844 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4845 informational suffixes of NAME (i.e., for which is_name_suffix is
4849 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4855 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4856 stored in the symbol table for nested function names is sometimes
4857 different from the name of the associated entity stored in
4858 the dwarf-2 data: This is the case for nested subprograms, where
4859 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4860 while the symbol name from the dwarf-2 data does not.
4862 Although the DWARF-2 standard documents that entity names stored
4863 in the dwarf-2 data should be identical to the name as seen in
4864 the source code, GNAT takes a different approach as we already use
4865 a special encoding mechanism to convey the information so that
4866 a C debugger can still use the information generated to debug
4867 Ada programs. A corollary is that the symbol names in the dwarf-2
4868 data should match the names found in the symbol table. I therefore
4869 consider this issue as a compiler defect.
4871 Until the compiler is properly fixed, we work-around the problem
4872 by ignoring such suffixes during the match. We do so by making
4873 a copy of PATN0 and NAME0, and then by stripping such a suffix
4874 if present. We then perform the match on the resulting strings. */
4877 name_len
= strlen (name0
);
4879 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4880 strcpy (name
, name0
);
4881 dot
= strrchr (name
, '.');
4882 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4885 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4886 strncpy (patn
, patn0
, patn_len
);
4887 patn
[patn_len
] = '\0';
4888 dot
= strrchr (patn
, '.');
4889 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4892 patn_len
= dot
- patn
;
4896 /* Now perform the wild match. */
4898 name_len
= strlen (name
);
4899 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4900 && strncmp (patn
, name
+ 5, patn_len
) == 0
4901 && is_name_suffix (name
+ patn_len
+ 5))
4904 while (name_len
>= patn_len
)
4906 if (strncmp (patn
, name
, patn_len
) == 0
4907 && is_name_suffix (name
+ patn_len
))
4908 return (is_valid_name_for_wild_match (name0
));
4915 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4920 if (!islower (name
[2]))
4927 if (!islower (name
[1]))
4938 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4939 vector *defn_symbols, updating the list of symbols in OBSTACKP
4940 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4941 OBJFILE is the section containing BLOCK.
4942 SYMTAB is recorded with each symbol added. */
4945 ada_add_block_symbols (struct obstack
*obstackp
,
4946 struct block
*block
, const char *name
,
4947 domain_enum domain
, struct objfile
*objfile
,
4948 struct symtab
*symtab
, int wild
)
4950 struct dict_iterator iter
;
4951 int name_len
= strlen (name
);
4952 /* A matching argument symbol, if any. */
4953 struct symbol
*arg_sym
;
4954 /* Set true when we find a matching non-argument symbol. */
4963 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4965 if (SYMBOL_DOMAIN (sym
) == domain
4966 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
4968 switch (SYMBOL_CLASS (sym
))
4974 case LOC_REGPARM_ADDR
:
4975 case LOC_BASEREG_ARG
:
4976 case LOC_COMPUTED_ARG
:
4979 case LOC_UNRESOLVED
:
4983 add_defn_to_vec (obstackp
,
4984 fixup_symbol_section (sym
, objfile
),
4993 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4995 if (SYMBOL_DOMAIN (sym
) == domain
)
4997 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
4999 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5001 switch (SYMBOL_CLASS (sym
))
5007 case LOC_REGPARM_ADDR
:
5008 case LOC_BASEREG_ARG
:
5009 case LOC_COMPUTED_ARG
:
5012 case LOC_UNRESOLVED
:
5016 add_defn_to_vec (obstackp
,
5017 fixup_symbol_section (sym
, objfile
),
5026 if (!found_sym
&& arg_sym
!= NULL
)
5028 add_defn_to_vec (obstackp
,
5029 fixup_symbol_section (arg_sym
, objfile
),
5038 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5040 if (SYMBOL_DOMAIN (sym
) == domain
)
5044 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5047 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5049 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5054 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5056 switch (SYMBOL_CLASS (sym
))
5062 case LOC_REGPARM_ADDR
:
5063 case LOC_BASEREG_ARG
:
5064 case LOC_COMPUTED_ARG
:
5067 case LOC_UNRESOLVED
:
5071 add_defn_to_vec (obstackp
,
5072 fixup_symbol_section (sym
, objfile
),
5080 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5081 They aren't parameters, right? */
5082 if (!found_sym
&& arg_sym
!= NULL
)
5084 add_defn_to_vec (obstackp
,
5085 fixup_symbol_section (arg_sym
, objfile
),
5093 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5094 to be invisible to users. */
5097 ada_is_ignored_field (struct type
*type
, int field_num
)
5099 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5103 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5104 return (name
== NULL
5105 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
5109 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
5110 pointer or reference type whose ultimate target has a tag field. */
5113 ada_is_tagged_type (struct type
*type
, int refok
)
5115 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
5118 /* True iff TYPE represents the type of X'Tag */
5121 ada_is_tag_type (struct type
*type
)
5123 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
5127 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
5128 return (name
!= NULL
5129 && strcmp (name
, "ada__tags__dispatch_table") == 0);
5133 /* The type of the tag on VAL. */
5136 ada_tag_type (struct value
*val
)
5138 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5141 /* The value of the tag on VAL. */
5144 ada_value_tag (struct value
*val
)
5146 return ada_value_struct_elt (val
, "_tag", "record");
5149 /* The value of the tag on the object of type TYPE whose contents are
5150 saved at VALADDR, if it is non-null, or is at memory address
5153 static struct value
*
5154 value_tag_from_contents_and_address (struct type
*type
,
5155 const gdb_byte
*valaddr
,
5158 int tag_byte_offset
, dummy1
, dummy2
;
5159 struct type
*tag_type
;
5160 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5163 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5165 : valaddr
+ tag_byte_offset
);
5166 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5168 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5173 static struct type
*
5174 type_from_tag (struct value
*tag
)
5176 const char *type_name
= ada_tag_name (tag
);
5177 if (type_name
!= NULL
)
5178 return ada_find_any_type (ada_encode (type_name
));
5189 static int ada_tag_name_1 (void *);
5190 static int ada_tag_name_2 (struct tag_args
*);
5192 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5193 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5194 The value stored in ARGS->name is valid until the next call to
5198 ada_tag_name_1 (void *args0
)
5200 struct tag_args
*args
= (struct tag_args
*) args0
;
5201 static char name
[1024];
5205 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
5207 return ada_tag_name_2 (args
);
5208 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
5211 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5212 for (p
= name
; *p
!= '\0'; p
+= 1)
5219 /* Utility function for ada_tag_name_1 that tries the second
5220 representation for the dispatch table (in which there is no
5221 explicit 'tsd' field in the referent of the tag pointer, and instead
5222 the tsd pointer is stored just before the dispatch table. */
5225 ada_tag_name_2 (struct tag_args
*args
)
5227 struct type
*info_type
;
5228 static char name
[1024];
5230 struct value
*val
, *valp
;
5233 info_type
= ada_find_any_type ("ada__tags__type_specific_data");
5234 if (info_type
== NULL
)
5236 info_type
= lookup_pointer_type (lookup_pointer_type (info_type
));
5237 valp
= value_cast (info_type
, args
->tag
);
5240 val
= value_ind (value_add (valp
, value_from_longest (builtin_type_int
, -1)));
5243 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
5246 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5247 for (p
= name
; *p
!= '\0'; p
+= 1)
5254 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5258 ada_tag_name (struct value
*tag
)
5260 struct tag_args args
;
5261 if (!ada_is_tag_type (value_type (tag
)))
5265 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5269 /* The parent type of TYPE, or NULL if none. */
5272 ada_parent_type (struct type
*type
)
5276 type
= ada_check_typedef (type
);
5278 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5281 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5282 if (ada_is_parent_field (type
, i
))
5283 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5288 /* True iff field number FIELD_NUM of structure type TYPE contains the
5289 parent-type (inherited) fields of a derived type. Assumes TYPE is
5290 a structure type with at least FIELD_NUM+1 fields. */
5293 ada_is_parent_field (struct type
*type
, int field_num
)
5295 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5296 return (name
!= NULL
5297 && (strncmp (name
, "PARENT", 6) == 0
5298 || strncmp (name
, "_parent", 7) == 0));
5301 /* True iff field number FIELD_NUM of structure type TYPE is a
5302 transparent wrapper field (which should be silently traversed when doing
5303 field selection and flattened when printing). Assumes TYPE is a
5304 structure type with at least FIELD_NUM+1 fields. Such fields are always
5308 ada_is_wrapper_field (struct type
*type
, int field_num
)
5310 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5311 return (name
!= NULL
5312 && (strncmp (name
, "PARENT", 6) == 0
5313 || strcmp (name
, "REP") == 0
5314 || strncmp (name
, "_parent", 7) == 0
5315 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5318 /* True iff field number FIELD_NUM of structure or union type TYPE
5319 is a variant wrapper. Assumes TYPE is a structure type with at least
5320 FIELD_NUM+1 fields. */
5323 ada_is_variant_part (struct type
*type
, int field_num
)
5325 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5326 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5327 || (is_dynamic_field (type
, field_num
)
5328 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5329 == TYPE_CODE_UNION
)));
5332 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5333 whose discriminants are contained in the record type OUTER_TYPE,
5334 returns the type of the controlling discriminant for the variant. */
5337 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5339 char *name
= ada_variant_discrim_name (var_type
);
5341 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5343 return builtin_type_int
;
5348 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5349 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5350 represents a 'when others' clause; otherwise 0. */
5353 ada_is_others_clause (struct type
*type
, int field_num
)
5355 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5356 return (name
!= NULL
&& name
[0] == 'O');
5359 /* Assuming that TYPE0 is the type of the variant part of a record,
5360 returns the name of the discriminant controlling the variant.
5361 The value is valid until the next call to ada_variant_discrim_name. */
5364 ada_variant_discrim_name (struct type
*type0
)
5366 static char *result
= NULL
;
5367 static size_t result_len
= 0;
5370 const char *discrim_end
;
5371 const char *discrim_start
;
5373 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5374 type
= TYPE_TARGET_TYPE (type0
);
5378 name
= ada_type_name (type
);
5380 if (name
== NULL
|| name
[0] == '\000')
5383 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5386 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5389 if (discrim_end
== name
)
5392 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5395 if (discrim_start
== name
+ 1)
5397 if ((discrim_start
> name
+ 3
5398 && strncmp (discrim_start
- 3, "___", 3) == 0)
5399 || discrim_start
[-1] == '.')
5403 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5404 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5405 result
[discrim_end
- discrim_start
] = '\0';
5409 /* Scan STR for a subtype-encoded number, beginning at position K.
5410 Put the position of the character just past the number scanned in
5411 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5412 Return 1 if there was a valid number at the given position, and 0
5413 otherwise. A "subtype-encoded" number consists of the absolute value
5414 in decimal, followed by the letter 'm' to indicate a negative number.
5415 Assumes 0m does not occur. */
5418 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5422 if (!isdigit (str
[k
]))
5425 /* Do it the hard way so as not to make any assumption about
5426 the relationship of unsigned long (%lu scan format code) and
5429 while (isdigit (str
[k
]))
5431 RU
= RU
* 10 + (str
[k
] - '0');
5438 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5444 /* NOTE on the above: Technically, C does not say what the results of
5445 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5446 number representable as a LONGEST (although either would probably work
5447 in most implementations). When RU>0, the locution in the then branch
5448 above is always equivalent to the negative of RU. */
5455 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5456 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5457 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5460 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5462 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5475 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5484 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5485 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5487 if (val
>= L
&& val
<= U
)
5499 /* FIXME: Lots of redundancy below. Try to consolidate. */
5501 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5502 ARG_TYPE, extract and return the value of one of its (non-static)
5503 fields. FIELDNO says which field. Differs from value_primitive_field
5504 only in that it can handle packed values of arbitrary type. */
5506 static struct value
*
5507 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5508 struct type
*arg_type
)
5512 arg_type
= ada_check_typedef (arg_type
);
5513 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5515 /* Handle packed fields. */
5517 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5519 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5520 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5522 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5523 offset
+ bit_pos
/ 8,
5524 bit_pos
% 8, bit_size
, type
);
5527 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5530 /* Find field with name NAME in object of type TYPE. If found, return 1
5531 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
5532 OFFSET + the byte offset of the field within an object of that type,
5533 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
5534 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
5535 Looks inside wrappers for the field. Returns 0 if field not
5538 find_struct_field (char *name
, struct type
*type
, int offset
,
5539 struct type
**field_type_p
,
5540 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
5544 type
= ada_check_typedef (type
);
5545 *field_type_p
= NULL
;
5546 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
5548 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5550 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
5551 int fld_offset
= offset
+ bit_pos
/ 8;
5552 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5554 if (t_field_name
== NULL
)
5557 else if (field_name_match (t_field_name
, name
))
5559 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
5560 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
5561 *byte_offset_p
= fld_offset
;
5562 *bit_offset_p
= bit_pos
% 8;
5563 *bit_size_p
= bit_size
;
5566 else if (ada_is_wrapper_field (type
, i
))
5568 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
5569 field_type_p
, byte_offset_p
, bit_offset_p
,
5573 else if (ada_is_variant_part (type
, i
))
5576 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5578 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5580 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
5582 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5583 field_type_p
, byte_offset_p
,
5584 bit_offset_p
, bit_size_p
))
5594 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5595 and search in it assuming it has (class) type TYPE.
5596 If found, return value, else return NULL.
5598 Searches recursively through wrapper fields (e.g., '_parent'). */
5600 static struct value
*
5601 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5605 type
= ada_check_typedef (type
);
5607 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5609 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5611 if (t_field_name
== NULL
)
5614 else if (field_name_match (t_field_name
, name
))
5615 return ada_value_primitive_field (arg
, offset
, i
, type
);
5617 else if (ada_is_wrapper_field (type
, i
))
5619 struct value
*v
= /* Do not let indent join lines here. */
5620 ada_search_struct_field (name
, arg
,
5621 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5622 TYPE_FIELD_TYPE (type
, i
));
5627 else if (ada_is_variant_part (type
, i
))
5630 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5631 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5633 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5635 struct value
*v
= ada_search_struct_field
/* Force line break. */
5637 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5638 TYPE_FIELD_TYPE (field_type
, j
));
5647 /* Given ARG, a value of type (pointer or reference to a)*
5648 structure/union, extract the component named NAME from the ultimate
5649 target structure/union and return it as a value with its
5650 appropriate type. If ARG is a pointer or reference and the field
5651 is not packed, returns a reference to the field, otherwise the
5652 value of the field (an lvalue if ARG is an lvalue).
5654 The routine searches for NAME among all members of the structure itself
5655 and (recursively) among all members of any wrapper members
5658 ERR is a name (for use in error messages) that identifies the class
5659 of entity that ARG is supposed to be. ERR may be null, indicating
5660 that on error, the function simply returns NULL, and does not
5661 throw an error. (FIXME: True only if ARG is a pointer or reference
5665 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5667 struct type
*t
, *t1
;
5671 t1
= t
= ada_check_typedef (value_type (arg
));
5672 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5674 t1
= TYPE_TARGET_TYPE (t
);
5680 error (_("Bad value type in a %s."), err
);
5682 t1
= ada_check_typedef (t1
);
5683 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5685 arg
= coerce_ref (arg
);
5690 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5692 t1
= TYPE_TARGET_TYPE (t
);
5698 error (_("Bad value type in a %s."), err
);
5700 t1
= ada_check_typedef (t1
);
5701 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5703 arg
= value_ind (arg
);
5710 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
5715 error (_("Attempt to extract a component of a value that is not a %s."),
5720 v
= ada_search_struct_field (name
, arg
, 0, t
);
5723 int bit_offset
, bit_size
, byte_offset
;
5724 struct type
*field_type
;
5727 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5728 address
= value_as_address (arg
);
5730 address
= unpack_pointer (t
, value_contents (arg
));
5732 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
5733 if (find_struct_field (name
, t1
, 0,
5734 &field_type
, &byte_offset
, &bit_offset
,
5739 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5740 arg
= ada_coerce_ref (arg
);
5742 arg
= ada_value_ind (arg
);
5743 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
5744 bit_offset
, bit_size
,
5748 v
= value_from_pointer (lookup_reference_type (field_type
),
5749 address
+ byte_offset
);
5753 if (v
== NULL
&& err
!= NULL
)
5754 error (_("There is no member named %s."), name
);
5759 /* Given a type TYPE, look up the type of the component of type named NAME.
5760 If DISPP is non-null, add its byte displacement from the beginning of a
5761 structure (pointed to by a value) of type TYPE to *DISPP (does not
5762 work for packed fields).
5764 Matches any field whose name has NAME as a prefix, possibly
5767 TYPE can be either a struct or union. If REFOK, TYPE may also
5768 be a (pointer or reference)+ to a struct or union, and the
5769 ultimate target type will be searched.
5771 Looks recursively into variant clauses and parent types.
5773 If NOERR is nonzero, return NULL if NAME is not suitably defined or
5774 TYPE is not a type of the right kind. */
5776 static struct type
*
5777 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
5778 int noerr
, int *dispp
)
5785 if (refok
&& type
!= NULL
)
5788 type
= ada_check_typedef (type
);
5789 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5790 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5792 type
= TYPE_TARGET_TYPE (type
);
5796 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
5797 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
5803 target_terminal_ours ();
5804 gdb_flush (gdb_stdout
);
5806 error (_("Type (null) is not a structure or union type"));
5809 /* XXX: type_sprint */
5810 fprintf_unfiltered (gdb_stderr
, _("Type "));
5811 type_print (type
, "", gdb_stderr
, -1);
5812 error (_(" is not a structure or union type"));
5817 type
= to_static_fixed_type (type
);
5819 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5821 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5825 if (t_field_name
== NULL
)
5828 else if (field_name_match (t_field_name
, name
))
5831 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5832 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5835 else if (ada_is_wrapper_field (type
, i
))
5838 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5843 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5848 else if (ada_is_variant_part (type
, i
))
5851 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5853 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5856 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5861 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5872 target_terminal_ours ();
5873 gdb_flush (gdb_stdout
);
5876 /* XXX: type_sprint */
5877 fprintf_unfiltered (gdb_stderr
, _("Type "));
5878 type_print (type
, "", gdb_stderr
, -1);
5879 error (_(" has no component named <null>"));
5883 /* XXX: type_sprint */
5884 fprintf_unfiltered (gdb_stderr
, _("Type "));
5885 type_print (type
, "", gdb_stderr
, -1);
5886 error (_(" has no component named %s"), name
);
5893 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5894 within a value of type OUTER_TYPE that is stored in GDB at
5895 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5896 numbering from 0) is applicable. Returns -1 if none are. */
5899 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5900 const gdb_byte
*outer_valaddr
)
5905 struct type
*discrim_type
;
5906 char *discrim_name
= ada_variant_discrim_name (var_type
);
5907 LONGEST discrim_val
;
5911 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
5912 if (discrim_type
== NULL
)
5914 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5917 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5919 if (ada_is_others_clause (var_type
, i
))
5921 else if (ada_in_variant (discrim_val
, var_type
, i
))
5925 return others_clause
;
5930 /* Dynamic-Sized Records */
5932 /* Strategy: The type ostensibly attached to a value with dynamic size
5933 (i.e., a size that is not statically recorded in the debugging
5934 data) does not accurately reflect the size or layout of the value.
5935 Our strategy is to convert these values to values with accurate,
5936 conventional types that are constructed on the fly. */
5938 /* There is a subtle and tricky problem here. In general, we cannot
5939 determine the size of dynamic records without its data. However,
5940 the 'struct value' data structure, which GDB uses to represent
5941 quantities in the inferior process (the target), requires the size
5942 of the type at the time of its allocation in order to reserve space
5943 for GDB's internal copy of the data. That's why the
5944 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5945 rather than struct value*s.
5947 However, GDB's internal history variables ($1, $2, etc.) are
5948 struct value*s containing internal copies of the data that are not, in
5949 general, the same as the data at their corresponding addresses in
5950 the target. Fortunately, the types we give to these values are all
5951 conventional, fixed-size types (as per the strategy described
5952 above), so that we don't usually have to perform the
5953 'to_fixed_xxx_type' conversions to look at their values.
5954 Unfortunately, there is one exception: if one of the internal
5955 history variables is an array whose elements are unconstrained
5956 records, then we will need to create distinct fixed types for each
5957 element selected. */
5959 /* The upshot of all of this is that many routines take a (type, host
5960 address, target address) triple as arguments to represent a value.
5961 The host address, if non-null, is supposed to contain an internal
5962 copy of the relevant data; otherwise, the program is to consult the
5963 target at the target address. */
5965 /* Assuming that VAL0 represents a pointer value, the result of
5966 dereferencing it. Differs from value_ind in its treatment of
5967 dynamic-sized types. */
5970 ada_value_ind (struct value
*val0
)
5972 struct value
*val
= unwrap_value (value_ind (val0
));
5973 return ada_to_fixed_value (val
);
5976 /* The value resulting from dereferencing any "reference to"
5977 qualifiers on VAL0. */
5979 static struct value
*
5980 ada_coerce_ref (struct value
*val0
)
5982 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
5984 struct value
*val
= val0
;
5985 val
= coerce_ref (val
);
5986 val
= unwrap_value (val
);
5987 return ada_to_fixed_value (val
);
5993 /* Return OFF rounded upward if necessary to a multiple of
5994 ALIGNMENT (a power of 2). */
5997 align_value (unsigned int off
, unsigned int alignment
)
5999 return (off
+ alignment
- 1) & ~(alignment
- 1);
6002 /* Return the bit alignment required for field #F of template type TYPE. */
6005 field_alignment (struct type
*type
, int f
)
6007 const char *name
= TYPE_FIELD_NAME (type
, f
);
6008 int len
= (name
== NULL
) ? 0 : strlen (name
);
6011 if (!isdigit (name
[len
- 1]))
6014 if (isdigit (name
[len
- 2]))
6015 align_offset
= len
- 2;
6017 align_offset
= len
- 1;
6019 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
6020 return TARGET_CHAR_BIT
;
6022 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
6025 /* Find a symbol named NAME. Ignores ambiguity. */
6028 ada_find_any_symbol (const char *name
)
6032 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
6033 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
6036 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
6040 /* Find a type named NAME. Ignores ambiguity. */
6043 ada_find_any_type (const char *name
)
6045 struct symbol
*sym
= ada_find_any_symbol (name
);
6048 return SYMBOL_TYPE (sym
);
6053 /* Given a symbol NAME and its associated BLOCK, search all symbols
6054 for its ___XR counterpart, which is the ``renaming'' symbol
6055 associated to NAME. Return this symbol if found, return
6059 ada_find_renaming_symbol (const char *name
, struct block
*block
)
6061 const struct symbol
*function_sym
= block_function (block
);
6064 if (function_sym
!= NULL
)
6066 /* If the symbol is defined inside a function, NAME is not fully
6067 qualified. This means we need to prepend the function name
6068 as well as adding the ``___XR'' suffix to build the name of
6069 the associated renaming symbol. */
6070 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
6071 /* Function names sometimes contain suffixes used
6072 for instance to qualify nested subprograms. When building
6073 the XR type name, we need to make sure that this suffix is
6074 not included. So do not include any suffix in the function
6075 name length below. */
6076 const int function_name_len
= ada_name_prefix_len (function_name
);
6077 const int rename_len
= function_name_len
+ 2 /* "__" */
6078 + strlen (name
) + 6 /* "___XR\0" */ ;
6080 /* Strip the suffix if necessary. */
6081 function_name
[function_name_len
] = '\0';
6083 /* Library-level functions are a special case, as GNAT adds
6084 a ``_ada_'' prefix to the function name to avoid namespace
6085 pollution. However, the renaming symbol themselves do not
6086 have this prefix, so we need to skip this prefix if present. */
6087 if (function_name_len
> 5 /* "_ada_" */
6088 && strstr (function_name
, "_ada_") == function_name
)
6089 function_name
= function_name
+ 5;
6091 rename
= (char *) alloca (rename_len
* sizeof (char));
6092 sprintf (rename
, "%s__%s___XR", function_name
, name
);
6096 const int rename_len
= strlen (name
) + 6;
6097 rename
= (char *) alloca (rename_len
* sizeof (char));
6098 sprintf (rename
, "%s___XR", name
);
6101 return ada_find_any_symbol (rename
);
6104 /* Because of GNAT encoding conventions, several GDB symbols may match a
6105 given type name. If the type denoted by TYPE0 is to be preferred to
6106 that of TYPE1 for purposes of type printing, return non-zero;
6107 otherwise return 0. */
6110 ada_prefer_type (struct type
*type0
, struct type
*type1
)
6114 else if (type0
== NULL
)
6116 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
6118 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
6120 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
6122 else if (ada_is_packed_array_type (type0
))
6124 else if (ada_is_array_descriptor_type (type0
)
6125 && !ada_is_array_descriptor_type (type1
))
6127 else if (ada_renaming_type (type0
) != NULL
6128 && ada_renaming_type (type1
) == NULL
)
6133 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
6134 null, its TYPE_TAG_NAME. Null if TYPE is null. */
6137 ada_type_name (struct type
*type
)
6141 else if (TYPE_NAME (type
) != NULL
)
6142 return TYPE_NAME (type
);
6144 return TYPE_TAG_NAME (type
);
6147 /* Find a parallel type to TYPE whose name is formed by appending
6148 SUFFIX to the name of TYPE. */
6151 ada_find_parallel_type (struct type
*type
, const char *suffix
)
6154 static size_t name_len
= 0;
6156 char *typename
= ada_type_name (type
);
6158 if (typename
== NULL
)
6161 len
= strlen (typename
);
6163 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
6165 strcpy (name
, typename
);
6166 strcpy (name
+ len
, suffix
);
6168 return ada_find_any_type (name
);
6172 /* If TYPE is a variable-size record type, return the corresponding template
6173 type describing its fields. Otherwise, return NULL. */
6175 static struct type
*
6176 dynamic_template_type (struct type
*type
)
6178 type
= ada_check_typedef (type
);
6180 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
6181 || ada_type_name (type
) == NULL
)
6185 int len
= strlen (ada_type_name (type
));
6186 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6189 return ada_find_parallel_type (type
, "___XVE");
6193 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6194 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6197 is_dynamic_field (struct type
*templ_type
, int field_num
)
6199 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6201 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6202 && strstr (name
, "___XVL") != NULL
;
6205 /* The index of the variant field of TYPE, or -1 if TYPE does not
6206 represent a variant record type. */
6209 variant_field_index (struct type
*type
)
6213 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6216 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6218 if (ada_is_variant_part (type
, f
))
6224 /* A record type with no fields. */
6226 static struct type
*
6227 empty_record (struct objfile
*objfile
)
6229 struct type
*type
= alloc_type (objfile
);
6230 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6231 TYPE_NFIELDS (type
) = 0;
6232 TYPE_FIELDS (type
) = NULL
;
6233 TYPE_NAME (type
) = "<empty>";
6234 TYPE_TAG_NAME (type
) = NULL
;
6235 TYPE_FLAGS (type
) = 0;
6236 TYPE_LENGTH (type
) = 0;
6240 /* An ordinary record type (with fixed-length fields) that describes
6241 the value of type TYPE at VALADDR or ADDRESS (see comments at
6242 the beginning of this section) VAL according to GNAT conventions.
6243 DVAL0 should describe the (portion of a) record that contains any
6244 necessary discriminants. It should be NULL if value_type (VAL) is
6245 an outer-level type (i.e., as opposed to a branch of a variant.) A
6246 variant field (unless unchecked) is replaced by a particular branch
6249 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6250 length are not statically known are discarded. As a consequence,
6251 VALADDR, ADDRESS and DVAL0 are ignored.
6253 NOTE: Limitations: For now, we assume that dynamic fields and
6254 variants occupy whole numbers of bytes. However, they need not be
6258 ada_template_to_fixed_record_type_1 (struct type
*type
,
6259 const gdb_byte
*valaddr
,
6260 CORE_ADDR address
, struct value
*dval0
,
6261 int keep_dynamic_fields
)
6263 struct value
*mark
= value_mark ();
6266 int nfields
, bit_len
;
6269 int fld_bit_len
, bit_incr
;
6272 /* Compute the number of fields in this record type that are going
6273 to be processed: unless keep_dynamic_fields, this includes only
6274 fields whose position and length are static will be processed. */
6275 if (keep_dynamic_fields
)
6276 nfields
= TYPE_NFIELDS (type
);
6280 while (nfields
< TYPE_NFIELDS (type
)
6281 && !ada_is_variant_part (type
, nfields
)
6282 && !is_dynamic_field (type
, nfields
))
6286 rtype
= alloc_type (TYPE_OBJFILE (type
));
6287 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6288 INIT_CPLUS_SPECIFIC (rtype
);
6289 TYPE_NFIELDS (rtype
) = nfields
;
6290 TYPE_FIELDS (rtype
) = (struct field
*)
6291 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6292 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6293 TYPE_NAME (rtype
) = ada_type_name (type
);
6294 TYPE_TAG_NAME (rtype
) = NULL
;
6295 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6301 for (f
= 0; f
< nfields
; f
+= 1)
6303 off
= align_value (off
, field_alignment (type
, f
))
6304 + TYPE_FIELD_BITPOS (type
, f
);
6305 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6306 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6308 if (ada_is_variant_part (type
, f
))
6311 fld_bit_len
= bit_incr
= 0;
6313 else if (is_dynamic_field (type
, f
))
6316 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6320 TYPE_FIELD_TYPE (rtype
, f
) =
6323 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6324 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6325 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6326 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6327 bit_incr
= fld_bit_len
=
6328 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6332 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6333 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6334 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6335 bit_incr
= fld_bit_len
=
6336 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6338 bit_incr
= fld_bit_len
=
6339 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6341 if (off
+ fld_bit_len
> bit_len
)
6342 bit_len
= off
+ fld_bit_len
;
6344 TYPE_LENGTH (rtype
) =
6345 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6348 /* We handle the variant part, if any, at the end because of certain
6349 odd cases in which it is re-ordered so as NOT the last field of
6350 the record. This can happen in the presence of representation
6352 if (variant_field
>= 0)
6354 struct type
*branch_type
;
6356 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6359 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6364 to_fixed_variant_branch_type
6365 (TYPE_FIELD_TYPE (type
, variant_field
),
6366 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6367 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6368 if (branch_type
== NULL
)
6370 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6371 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6372 TYPE_NFIELDS (rtype
) -= 1;
6376 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6377 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6379 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6381 if (off
+ fld_bit_len
> bit_len
)
6382 bit_len
= off
+ fld_bit_len
;
6383 TYPE_LENGTH (rtype
) =
6384 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6388 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6389 should contain the alignment of that record, which should be a strictly
6390 positive value. If null or negative, then something is wrong, most
6391 probably in the debug info. In that case, we don't round up the size
6392 of the resulting type. If this record is not part of another structure,
6393 the current RTYPE length might be good enough for our purposes. */
6394 if (TYPE_LENGTH (type
) <= 0)
6396 if (TYPE_NAME (rtype
))
6397 warning (_("Invalid type size for `%s' detected: %d."),
6398 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6400 warning (_("Invalid type size for <unnamed> detected: %d."),
6401 TYPE_LENGTH (type
));
6405 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6406 TYPE_LENGTH (type
));
6409 value_free_to_mark (mark
);
6410 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6411 error (_("record type with dynamic size is larger than varsize-limit"));
6415 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6418 static struct type
*
6419 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
6420 CORE_ADDR address
, struct value
*dval0
)
6422 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6426 /* An ordinary record type in which ___XVL-convention fields and
6427 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6428 static approximations, containing all possible fields. Uses
6429 no runtime values. Useless for use in values, but that's OK,
6430 since the results are used only for type determinations. Works on both
6431 structs and unions. Representation note: to save space, we memorize
6432 the result of this function in the TYPE_TARGET_TYPE of the
6435 static struct type
*
6436 template_to_static_fixed_type (struct type
*type0
)
6442 if (TYPE_TARGET_TYPE (type0
) != NULL
)
6443 return TYPE_TARGET_TYPE (type0
);
6445 nfields
= TYPE_NFIELDS (type0
);
6448 for (f
= 0; f
< nfields
; f
+= 1)
6450 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
6451 struct type
*new_type
;
6453 if (is_dynamic_field (type0
, f
))
6454 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
6456 new_type
= to_static_fixed_type (field_type
);
6457 if (type
== type0
&& new_type
!= field_type
)
6459 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
6460 TYPE_CODE (type
) = TYPE_CODE (type0
);
6461 INIT_CPLUS_SPECIFIC (type
);
6462 TYPE_NFIELDS (type
) = nfields
;
6463 TYPE_FIELDS (type
) = (struct field
*)
6464 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6465 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
6466 sizeof (struct field
) * nfields
);
6467 TYPE_NAME (type
) = ada_type_name (type0
);
6468 TYPE_TAG_NAME (type
) = NULL
;
6469 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
6470 TYPE_LENGTH (type
) = 0;
6472 TYPE_FIELD_TYPE (type
, f
) = new_type
;
6473 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
6478 /* Given an object of type TYPE whose contents are at VALADDR and
6479 whose address in memory is ADDRESS, returns a revision of TYPE --
6480 a non-dynamic-sized record with a variant part -- in which
6481 the variant part is replaced with the appropriate branch. Looks
6482 for discriminant values in DVAL0, which can be NULL if the record
6483 contains the necessary discriminant values. */
6485 static struct type
*
6486 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
6487 CORE_ADDR address
, struct value
*dval0
)
6489 struct value
*mark
= value_mark ();
6492 struct type
*branch_type
;
6493 int nfields
= TYPE_NFIELDS (type
);
6494 int variant_field
= variant_field_index (type
);
6496 if (variant_field
== -1)
6500 dval
= value_from_contents_and_address (type
, valaddr
, address
);
6504 rtype
= alloc_type (TYPE_OBJFILE (type
));
6505 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6506 INIT_CPLUS_SPECIFIC (rtype
);
6507 TYPE_NFIELDS (rtype
) = nfields
;
6508 TYPE_FIELDS (rtype
) =
6509 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6510 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6511 sizeof (struct field
) * nfields
);
6512 TYPE_NAME (rtype
) = ada_type_name (type
);
6513 TYPE_TAG_NAME (rtype
) = NULL
;
6514 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6515 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6517 branch_type
= to_fixed_variant_branch_type
6518 (TYPE_FIELD_TYPE (type
, variant_field
),
6519 cond_offset_host (valaddr
,
6520 TYPE_FIELD_BITPOS (type
, variant_field
)
6522 cond_offset_target (address
,
6523 TYPE_FIELD_BITPOS (type
, variant_field
)
6524 / TARGET_CHAR_BIT
), dval
);
6525 if (branch_type
== NULL
)
6528 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
6529 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6530 TYPE_NFIELDS (rtype
) -= 1;
6534 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6535 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6536 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
6537 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6539 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
6541 value_free_to_mark (mark
);
6545 /* An ordinary record type (with fixed-length fields) that describes
6546 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6547 beginning of this section]. Any necessary discriminants' values
6548 should be in DVAL, a record value; it may be NULL if the object
6549 at ADDR itself contains any necessary discriminant values.
6550 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6551 values from the record are needed. Except in the case that DVAL,
6552 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6553 unchecked) is replaced by a particular branch of the variant.
6555 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6556 is questionable and may be removed. It can arise during the
6557 processing of an unconstrained-array-of-record type where all the
6558 variant branches have exactly the same size. This is because in
6559 such cases, the compiler does not bother to use the XVS convention
6560 when encoding the record. I am currently dubious of this
6561 shortcut and suspect the compiler should be altered. FIXME. */
6563 static struct type
*
6564 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
6565 CORE_ADDR address
, struct value
*dval
)
6567 struct type
*templ_type
;
6569 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6572 templ_type
= dynamic_template_type (type0
);
6574 if (templ_type
!= NULL
)
6575 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6576 else if (variant_field_index (type0
) >= 0)
6578 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
6580 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
6585 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
6591 /* An ordinary record type (with fixed-length fields) that describes
6592 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6593 union type. Any necessary discriminants' values should be in DVAL,
6594 a record value. That is, this routine selects the appropriate
6595 branch of the union at ADDR according to the discriminant value
6596 indicated in the union's type name. */
6598 static struct type
*
6599 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
6600 CORE_ADDR address
, struct value
*dval
)
6603 struct type
*templ_type
;
6604 struct type
*var_type
;
6606 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6607 var_type
= TYPE_TARGET_TYPE (var_type0
);
6609 var_type
= var_type0
;
6611 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6613 if (templ_type
!= NULL
)
6614 var_type
= templ_type
;
6617 ada_which_variant_applies (var_type
,
6618 value_type (dval
), value_contents (dval
));
6621 return empty_record (TYPE_OBJFILE (var_type
));
6622 else if (is_dynamic_field (var_type
, which
))
6623 return to_fixed_record_type
6624 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6625 valaddr
, address
, dval
);
6626 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
6628 to_fixed_record_type
6629 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6631 return TYPE_FIELD_TYPE (var_type
, which
);
6634 /* Assuming that TYPE0 is an array type describing the type of a value
6635 at ADDR, and that DVAL describes a record containing any
6636 discriminants used in TYPE0, returns a type for the value that
6637 contains no dynamic components (that is, no components whose sizes
6638 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6639 true, gives an error message if the resulting type's size is over
6642 static struct type
*
6643 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6646 struct type
*index_type_desc
;
6647 struct type
*result
;
6649 if (ada_is_packed_array_type (type0
) /* revisit? */
6650 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
6653 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6654 if (index_type_desc
== NULL
)
6656 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
6657 /* NOTE: elt_type---the fixed version of elt_type0---should never
6658 depend on the contents of the array in properly constructed
6660 /* Create a fixed version of the array element type.
6661 We're not providing the address of an element here,
6662 and thus the actual object value can not be inspected to do
6663 the conversion. This should not be a problem, since arrays of
6664 unconstrained objects are not allowed. In particular, all
6665 the elements of an array of a tagged type should all be of
6666 the same type specified in the debugging info. No need to
6667 consult the object tag. */
6668 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6670 if (elt_type0
== elt_type
)
6673 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6674 elt_type
, TYPE_INDEX_TYPE (type0
));
6679 struct type
*elt_type0
;
6682 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6683 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6685 /* NOTE: result---the fixed version of elt_type0---should never
6686 depend on the contents of the array in properly constructed
6688 /* Create a fixed version of the array element type.
6689 We're not providing the address of an element here,
6690 and thus the actual object value can not be inspected to do
6691 the conversion. This should not be a problem, since arrays of
6692 unconstrained objects are not allowed. In particular, all
6693 the elements of an array of a tagged type should all be of
6694 the same type specified in the debugging info. No need to
6695 consult the object tag. */
6696 result
= ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
);
6697 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6699 struct type
*range_type
=
6700 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6701 dval
, TYPE_OBJFILE (type0
));
6702 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6703 result
, range_type
);
6705 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6706 error (_("array type with dynamic size is larger than varsize-limit"));
6709 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
6714 /* A standard type (containing no dynamically sized components)
6715 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6716 DVAL describes a record containing any discriminants used in TYPE0,
6717 and may be NULL if there are none, or if the object of type TYPE at
6718 ADDRESS or in VALADDR contains these discriminants.
6720 In the case of tagged types, this function attempts to locate the object's
6721 tag and use it to compute the actual type. However, when ADDRESS is null,
6722 we cannot use it to determine the location of the tag, and therefore
6723 compute the tagged type's actual type. So we return the tagged type
6724 without consulting the tag. */
6727 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
6728 CORE_ADDR address
, struct value
*dval
)
6730 type
= ada_check_typedef (type
);
6731 switch (TYPE_CODE (type
))
6735 case TYPE_CODE_STRUCT
:
6737 struct type
*static_type
= to_static_fixed_type (type
);
6739 /* If STATIC_TYPE is a tagged type and we know the object's address,
6740 then we can determine its tag, and compute the object's actual
6743 if (address
!= 0 && ada_is_tagged_type (static_type
, 0))
6745 struct type
*real_type
=
6746 type_from_tag (value_tag_from_contents_and_address (static_type
,
6749 if (real_type
!= NULL
)
6752 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6754 case TYPE_CODE_ARRAY
:
6755 return to_fixed_array_type (type
, dval
, 1);
6756 case TYPE_CODE_UNION
:
6760 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6764 /* A standard (static-sized) type corresponding as well as possible to
6765 TYPE0, but based on no runtime data. */
6767 static struct type
*
6768 to_static_fixed_type (struct type
*type0
)
6775 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6778 type0
= ada_check_typedef (type0
);
6780 switch (TYPE_CODE (type0
))
6784 case TYPE_CODE_STRUCT
:
6785 type
= dynamic_template_type (type0
);
6787 return template_to_static_fixed_type (type
);
6789 return template_to_static_fixed_type (type0
);
6790 case TYPE_CODE_UNION
:
6791 type
= ada_find_parallel_type (type0
, "___XVU");
6793 return template_to_static_fixed_type (type
);
6795 return template_to_static_fixed_type (type0
);
6799 /* A static approximation of TYPE with all type wrappers removed. */
6801 static struct type
*
6802 static_unwrap_type (struct type
*type
)
6804 if (ada_is_aligner_type (type
))
6806 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
6807 if (ada_type_name (type1
) == NULL
)
6808 TYPE_NAME (type1
) = ada_type_name (type
);
6810 return static_unwrap_type (type1
);
6814 struct type
*raw_real_type
= ada_get_base_type (type
);
6815 if (raw_real_type
== type
)
6818 return to_static_fixed_type (raw_real_type
);
6822 /* In some cases, incomplete and private types require
6823 cross-references that are not resolved as records (for example,
6825 type FooP is access Foo;
6827 type Foo is array ...;
6828 ). In these cases, since there is no mechanism for producing
6829 cross-references to such types, we instead substitute for FooP a
6830 stub enumeration type that is nowhere resolved, and whose tag is
6831 the name of the actual type. Call these types "non-record stubs". */
6833 /* A type equivalent to TYPE that is not a non-record stub, if one
6834 exists, otherwise TYPE. */
6837 ada_check_typedef (struct type
*type
)
6839 CHECK_TYPEDEF (type
);
6840 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6841 || !TYPE_STUB (type
)
6842 || TYPE_TAG_NAME (type
) == NULL
)
6846 char *name
= TYPE_TAG_NAME (type
);
6847 struct type
*type1
= ada_find_any_type (name
);
6848 return (type1
== NULL
) ? type
: type1
;
6852 /* A value representing the data at VALADDR/ADDRESS as described by
6853 type TYPE0, but with a standard (static-sized) type that correctly
6854 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6855 type, then return VAL0 [this feature is simply to avoid redundant
6856 creation of struct values]. */
6858 static struct value
*
6859 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
6862 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
6863 if (type
== type0
&& val0
!= NULL
)
6866 return value_from_contents_and_address (type
, 0, address
);
6869 /* A value representing VAL, but with a standard (static-sized) type
6870 that correctly describes it. Does not necessarily create a new
6873 static struct value
*
6874 ada_to_fixed_value (struct value
*val
)
6876 return ada_to_fixed_value_create (value_type (val
),
6877 VALUE_ADDRESS (val
) + value_offset (val
),
6881 /* A value representing VAL, but with a standard (static-sized) type
6882 chosen to approximate the real type of VAL as well as possible, but
6883 without consulting any runtime values. For Ada dynamic-sized
6884 types, therefore, the type of the result is likely to be inaccurate. */
6887 ada_to_static_fixed_value (struct value
*val
)
6890 to_static_fixed_type (static_unwrap_type (value_type (val
)));
6891 if (type
== value_type (val
))
6894 return coerce_unspec_val_to_type (val
, type
);
6900 /* Table mapping attribute numbers to names.
6901 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
6903 static const char *attribute_names
[] = {
6921 ada_attribute_name (enum exp_opcode n
)
6923 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
6924 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
6926 return attribute_names
[0];
6929 /* Evaluate the 'POS attribute applied to ARG. */
6932 pos_atr (struct value
*arg
)
6934 struct type
*type
= value_type (arg
);
6936 if (!discrete_type_p (type
))
6937 error (_("'POS only defined on discrete types"));
6939 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6942 LONGEST v
= value_as_long (arg
);
6944 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6946 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6949 error (_("enumeration value is invalid: can't find 'POS"));
6952 return value_as_long (arg
);
6955 static struct value
*
6956 value_pos_atr (struct value
*arg
)
6958 return value_from_longest (builtin_type_int
, pos_atr (arg
));
6961 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6963 static struct value
*
6964 value_val_atr (struct type
*type
, struct value
*arg
)
6966 if (!discrete_type_p (type
))
6967 error (_("'VAL only defined on discrete types"));
6968 if (!integer_type_p (value_type (arg
)))
6969 error (_("'VAL requires integral argument"));
6971 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6973 long pos
= value_as_long (arg
);
6974 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6975 error (_("argument to 'VAL out of range"));
6976 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6979 return value_from_longest (type
, value_as_long (arg
));
6985 /* True if TYPE appears to be an Ada character type.
6986 [At the moment, this is true only for Character and Wide_Character;
6987 It is a heuristic test that could stand improvement]. */
6990 ada_is_character_type (struct type
*type
)
6992 const char *name
= ada_type_name (type
);
6995 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6996 || TYPE_CODE (type
) == TYPE_CODE_INT
6997 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6998 && (strcmp (name
, "character") == 0
6999 || strcmp (name
, "wide_character") == 0
7000 || strcmp (name
, "unsigned char") == 0);
7003 /* True if TYPE appears to be an Ada string type. */
7006 ada_is_string_type (struct type
*type
)
7008 type
= ada_check_typedef (type
);
7010 && TYPE_CODE (type
) != TYPE_CODE_PTR
7011 && (ada_is_simple_array_type (type
)
7012 || ada_is_array_descriptor_type (type
))
7013 && ada_array_arity (type
) == 1)
7015 struct type
*elttype
= ada_array_element_type (type
, 1);
7017 return ada_is_character_type (elttype
);
7024 /* True if TYPE is a struct type introduced by the compiler to force the
7025 alignment of a value. Such types have a single field with a
7026 distinctive name. */
7029 ada_is_aligner_type (struct type
*type
)
7031 type
= ada_check_typedef (type
);
7033 /* If we can find a parallel XVS type, then the XVS type should
7034 be used instead of this type. And hence, this is not an aligner
7036 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
7039 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
7040 && TYPE_NFIELDS (type
) == 1
7041 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
7044 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
7045 the parallel type. */
7048 ada_get_base_type (struct type
*raw_type
)
7050 struct type
*real_type_namer
;
7051 struct type
*raw_real_type
;
7053 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
7056 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
7057 if (real_type_namer
== NULL
7058 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
7059 || TYPE_NFIELDS (real_type_namer
) != 1)
7062 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
7063 if (raw_real_type
== NULL
)
7066 return raw_real_type
;
7069 /* The type of value designated by TYPE, with all aligners removed. */
7072 ada_aligned_type (struct type
*type
)
7074 if (ada_is_aligner_type (type
))
7075 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
7077 return ada_get_base_type (type
);
7081 /* The address of the aligned value in an object at address VALADDR
7082 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
7085 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
7087 if (ada_is_aligner_type (type
))
7088 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
7090 TYPE_FIELD_BITPOS (type
,
7091 0) / TARGET_CHAR_BIT
);
7098 /* The printed representation of an enumeration literal with encoded
7099 name NAME. The value is good to the next call of ada_enum_name. */
7101 ada_enum_name (const char *name
)
7103 static char *result
;
7104 static size_t result_len
= 0;
7107 /* First, unqualify the enumeration name:
7108 1. Search for the last '.' character. If we find one, then skip
7109 all the preceeding characters, the unqualified name starts
7110 right after that dot.
7111 2. Otherwise, we may be debugging on a target where the compiler
7112 translates dots into "__". Search forward for double underscores,
7113 but stop searching when we hit an overloading suffix, which is
7114 of the form "__" followed by digits. */
7116 tmp
= strrchr (name
, '.');
7121 while ((tmp
= strstr (name
, "__")) != NULL
)
7123 if (isdigit (tmp
[2]))
7133 if (name
[1] == 'U' || name
[1] == 'W')
7135 if (sscanf (name
+ 2, "%x", &v
) != 1)
7141 GROW_VECT (result
, result_len
, 16);
7142 if (isascii (v
) && isprint (v
))
7143 sprintf (result
, "'%c'", v
);
7144 else if (name
[1] == 'U')
7145 sprintf (result
, "[\"%02x\"]", v
);
7147 sprintf (result
, "[\"%04x\"]", v
);
7153 tmp
= strstr (name
, "__");
7155 tmp
= strstr (name
, "$");
7158 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
7159 strncpy (result
, name
, tmp
- name
);
7160 result
[tmp
- name
] = '\0';
7168 static struct value
*
7169 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
7172 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7173 (expect_type
, exp
, pos
, noside
);
7176 /* Evaluate the subexpression of EXP starting at *POS as for
7177 evaluate_type, updating *POS to point just past the evaluated
7180 static struct value
*
7181 evaluate_subexp_type (struct expression
*exp
, int *pos
)
7183 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
7184 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
7187 /* If VAL is wrapped in an aligner or subtype wrapper, return the
7190 static struct value
*
7191 unwrap_value (struct value
*val
)
7193 struct type
*type
= ada_check_typedef (value_type (val
));
7194 if (ada_is_aligner_type (type
))
7196 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
7197 NULL
, "internal structure");
7198 struct type
*val_type
= ada_check_typedef (value_type (v
));
7199 if (ada_type_name (val_type
) == NULL
)
7200 TYPE_NAME (val_type
) = ada_type_name (type
);
7202 return unwrap_value (v
);
7206 struct type
*raw_real_type
=
7207 ada_check_typedef (ada_get_base_type (type
));
7209 if (type
== raw_real_type
)
7213 coerce_unspec_val_to_type
7214 (val
, ada_to_fixed_type (raw_real_type
, 0,
7215 VALUE_ADDRESS (val
) + value_offset (val
),
7220 static struct value
*
7221 cast_to_fixed (struct type
*type
, struct value
*arg
)
7225 if (type
== value_type (arg
))
7227 else if (ada_is_fixed_point_type (value_type (arg
)))
7228 val
= ada_float_to_fixed (type
,
7229 ada_fixed_to_float (value_type (arg
),
7230 value_as_long (arg
)));
7234 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
7235 val
= ada_float_to_fixed (type
, argd
);
7238 return value_from_longest (type
, val
);
7241 static struct value
*
7242 cast_from_fixed_to_double (struct value
*arg
)
7244 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7245 value_as_long (arg
));
7246 return value_from_double (builtin_type_double
, val
);
7249 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7250 return the converted value. */
7252 static struct value
*
7253 coerce_for_assign (struct type
*type
, struct value
*val
)
7255 struct type
*type2
= value_type (val
);
7259 type2
= ada_check_typedef (type2
);
7260 type
= ada_check_typedef (type
);
7262 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7263 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7265 val
= ada_value_ind (val
);
7266 type2
= value_type (val
);
7269 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7270 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7272 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7273 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7274 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7275 error (_("Incompatible types in assignment"));
7276 deprecated_set_value_type (val
, type
);
7281 static struct value
*
7282 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7285 struct type
*type1
, *type2
;
7288 arg1
= coerce_ref (arg1
);
7289 arg2
= coerce_ref (arg2
);
7290 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7291 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7293 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7294 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7295 return value_binop (arg1
, arg2
, op
);
7304 return value_binop (arg1
, arg2
, op
);
7307 v2
= value_as_long (arg2
);
7309 error (_("second operand of %s must not be zero."), op_string (op
));
7311 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7312 return value_binop (arg1
, arg2
, op
);
7314 v1
= value_as_long (arg1
);
7319 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7320 v
+= v
> 0 ? -1 : 1;
7328 /* Should not reach this point. */
7332 val
= allocate_value (type1
);
7333 store_unsigned_integer (value_contents_raw (val
),
7334 TYPE_LENGTH (value_type (val
)), v
);
7339 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7341 if (ada_is_direct_array_type (value_type (arg1
))
7342 || ada_is_direct_array_type (value_type (arg2
)))
7344 arg1
= ada_coerce_to_simple_array (arg1
);
7345 arg2
= ada_coerce_to_simple_array (arg2
);
7346 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
7347 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
7348 error (_("Attempt to compare array with non-array"));
7349 /* FIXME: The following works only for types whose
7350 representations use all bits (no padding or undefined bits)
7351 and do not have user-defined equality. */
7353 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
7354 && memcmp (value_contents (arg1
), value_contents (arg2
),
7355 TYPE_LENGTH (value_type (arg1
))) == 0;
7357 return value_equal (arg1
, arg2
);
7361 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
7362 int *pos
, enum noside noside
)
7365 int tem
, tem2
, tem3
;
7367 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
7370 struct value
**argvec
;
7374 op
= exp
->elts
[pc
].opcode
;
7381 unwrap_value (evaluate_subexp_standard
7382 (expect_type
, exp
, pos
, noside
));
7386 struct value
*result
;
7388 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
7389 /* The result type will have code OP_STRING, bashed there from
7390 OP_ARRAY. Bash it back. */
7391 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
7392 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
7398 type
= exp
->elts
[pc
+ 1].type
;
7399 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
7400 if (noside
== EVAL_SKIP
)
7402 if (type
!= ada_check_typedef (value_type (arg1
)))
7404 if (ada_is_fixed_point_type (type
))
7405 arg1
= cast_to_fixed (type
, arg1
);
7406 else if (ada_is_fixed_point_type (value_type (arg1
)))
7407 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
7408 else if (VALUE_LVAL (arg1
) == lval_memory
)
7410 /* This is in case of the really obscure (and undocumented,
7411 but apparently expected) case of (Foo) Bar.all, where Bar
7412 is an integer constant and Foo is a dynamic-sized type.
7413 If we don't do this, ARG1 will simply be relabeled with
7415 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7416 return value_zero (to_static_fixed_type (type
), not_lval
);
7418 ada_to_fixed_value_create
7419 (type
, VALUE_ADDRESS (arg1
) + value_offset (arg1
), 0);
7422 arg1
= value_cast (type
, arg1
);
7428 type
= exp
->elts
[pc
+ 1].type
;
7429 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
7432 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7433 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7434 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7436 if (ada_is_fixed_point_type (value_type (arg1
)))
7437 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
7438 else if (ada_is_fixed_point_type (value_type (arg2
)))
7440 (_("Fixed-point values must be assigned to fixed-point variables"));
7442 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
7443 return ada_value_assign (arg1
, arg2
);
7446 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7447 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7448 if (noside
== EVAL_SKIP
)
7450 if ((ada_is_fixed_point_type (value_type (arg1
))
7451 || ada_is_fixed_point_type (value_type (arg2
)))
7452 && value_type (arg1
) != value_type (arg2
))
7453 error (_("Operands of fixed-point addition must have the same type"));
7454 return value_cast (value_type (arg1
), value_add (arg1
, arg2
));
7457 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7458 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7459 if (noside
== EVAL_SKIP
)
7461 if ((ada_is_fixed_point_type (value_type (arg1
))
7462 || ada_is_fixed_point_type (value_type (arg2
)))
7463 && value_type (arg1
) != value_type (arg2
))
7464 error (_("Operands of fixed-point subtraction must have the same type"));
7465 return value_cast (value_type (arg1
), value_sub (arg1
, arg2
));
7469 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7470 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7471 if (noside
== EVAL_SKIP
)
7473 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7474 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7475 return value_zero (value_type (arg1
), not_lval
);
7478 if (ada_is_fixed_point_type (value_type (arg1
)))
7479 arg1
= cast_from_fixed_to_double (arg1
);
7480 if (ada_is_fixed_point_type (value_type (arg2
)))
7481 arg2
= cast_from_fixed_to_double (arg2
);
7482 return ada_value_binop (arg1
, arg2
, op
);
7487 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7488 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7489 if (noside
== EVAL_SKIP
)
7491 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7492 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7493 return value_zero (value_type (arg1
), not_lval
);
7495 return ada_value_binop (arg1
, arg2
, op
);
7498 case BINOP_NOTEQUAL
:
7499 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7500 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7501 if (noside
== EVAL_SKIP
)
7503 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7506 tem
= ada_value_equal (arg1
, arg2
);
7507 if (op
== BINOP_NOTEQUAL
)
7509 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
7512 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7513 if (noside
== EVAL_SKIP
)
7515 else if (ada_is_fixed_point_type (value_type (arg1
)))
7516 return value_cast (value_type (arg1
), value_neg (arg1
));
7518 return value_neg (arg1
);
7522 if (noside
== EVAL_SKIP
)
7527 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
7528 /* Only encountered when an unresolved symbol occurs in a
7529 context other than a function call, in which case, it is
7531 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7532 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
7533 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7537 (to_static_fixed_type
7538 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7544 unwrap_value (evaluate_subexp_standard
7545 (expect_type
, exp
, pos
, noside
));
7546 return ada_to_fixed_value (arg1
);
7552 /* Allocate arg vector, including space for the function to be
7553 called in argvec[0] and a terminating NULL. */
7554 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7556 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
7558 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
7559 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
7560 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7561 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
7564 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7565 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7568 if (noside
== EVAL_SKIP
)
7572 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
7573 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7574 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
7575 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
7576 && VALUE_LVAL (argvec
[0]) == lval_memory
))
7577 argvec
[0] = value_addr (argvec
[0]);
7579 type
= ada_check_typedef (value_type (argvec
[0]));
7580 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7582 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
7584 case TYPE_CODE_FUNC
:
7585 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7587 case TYPE_CODE_ARRAY
:
7589 case TYPE_CODE_STRUCT
:
7590 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7591 argvec
[0] = ada_value_ind (argvec
[0]);
7592 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7595 error (_("cannot subscript or call something of type `%s'"),
7596 ada_type_name (value_type (argvec
[0])));
7601 switch (TYPE_CODE (type
))
7603 case TYPE_CODE_FUNC
:
7604 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7605 return allocate_value (TYPE_TARGET_TYPE (type
));
7606 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7607 case TYPE_CODE_STRUCT
:
7611 arity
= ada_array_arity (type
);
7612 type
= ada_array_element_type (type
, nargs
);
7614 error (_("cannot subscript or call a record"));
7616 error (_("wrong number of subscripts; expecting %d"), arity
);
7617 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7618 return allocate_value (ada_aligned_type (type
));
7620 unwrap_value (ada_value_subscript
7621 (argvec
[0], nargs
, argvec
+ 1));
7623 case TYPE_CODE_ARRAY
:
7624 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7626 type
= ada_array_element_type (type
, nargs
);
7628 error (_("element type of array unknown"));
7630 return allocate_value (ada_aligned_type (type
));
7633 unwrap_value (ada_value_subscript
7634 (ada_coerce_to_simple_array (argvec
[0]),
7635 nargs
, argvec
+ 1));
7636 case TYPE_CODE_PTR
: /* Pointer to array */
7637 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7638 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7640 type
= ada_array_element_type (type
, nargs
);
7642 error (_("element type of array unknown"));
7644 return allocate_value (ada_aligned_type (type
));
7647 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7648 nargs
, argvec
+ 1));
7651 error (_("Attempt to index or call something other than an \
7652 array or function"));
7657 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7658 struct value
*low_bound_val
=
7659 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7660 struct value
*high_bound_val
=
7661 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7664 low_bound_val
= coerce_ref (low_bound_val
);
7665 high_bound_val
= coerce_ref (high_bound_val
);
7666 low_bound
= pos_atr (low_bound_val
);
7667 high_bound
= pos_atr (high_bound_val
);
7669 if (noside
== EVAL_SKIP
)
7672 /* If this is a reference to an aligner type, then remove all
7674 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7675 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
7676 TYPE_TARGET_TYPE (value_type (array
)) =
7677 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
7679 if (ada_is_packed_array_type (value_type (array
)))
7680 error (_("cannot slice a packed array"));
7682 /* If this is a reference to an array or an array lvalue,
7683 convert to a pointer. */
7684 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7685 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
7686 && VALUE_LVAL (array
) == lval_memory
))
7687 array
= value_addr (array
);
7689 if (noside
== EVAL_AVOID_SIDE_EFFECTS
7690 && ada_is_array_descriptor_type (ada_check_typedef
7691 (value_type (array
))))
7692 return empty_array (ada_type_of_array (array
, 0), low_bound
);
7694 array
= ada_coerce_to_simple_array_ptr (array
);
7696 /* If we have more than one level of pointer indirection,
7697 dereference the value until we get only one level. */
7698 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
7699 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
7701 array
= value_ind (array
);
7703 /* Make sure we really do have an array type before going further,
7704 to avoid a SEGV when trying to get the index type or the target
7705 type later down the road if the debug info generated by
7706 the compiler is incorrect or incomplete. */
7707 if (!ada_is_simple_array_type (value_type (array
)))
7708 error (_("cannot take slice of non-array"));
7710 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
7712 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7713 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
7717 struct type
*arr_type0
=
7718 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
7720 return ada_value_slice_ptr (array
, arr_type0
,
7721 longest_to_int (low_bound
),
7722 longest_to_int (high_bound
));
7725 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7727 else if (high_bound
< low_bound
)
7728 return empty_array (value_type (array
), low_bound
);
7730 return ada_value_slice (array
, longest_to_int (low_bound
),
7731 longest_to_int (high_bound
));
7736 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7737 type
= exp
->elts
[pc
+ 1].type
;
7739 if (noside
== EVAL_SKIP
)
7742 switch (TYPE_CODE (type
))
7745 lim_warning (_("Membership test incompletely implemented; \
7746 always returns true"));
7747 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
7749 case TYPE_CODE_RANGE
:
7750 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
7751 arg3
= value_from_longest (builtin_type_int
,
7752 TYPE_HIGH_BOUND (type
));
7754 value_from_longest (builtin_type_int
,
7755 (value_less (arg1
, arg3
)
7756 || value_equal (arg1
, arg3
))
7757 && (value_less (arg2
, arg1
)
7758 || value_equal (arg2
, arg1
)));
7761 case BINOP_IN_BOUNDS
:
7763 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7764 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7766 if (noside
== EVAL_SKIP
)
7769 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7770 return value_zero (builtin_type_int
, not_lval
);
7772 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7774 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
7775 error (_("invalid dimension number to 'range"));
7777 arg3
= ada_array_bound (arg2
, tem
, 1);
7778 arg2
= ada_array_bound (arg2
, tem
, 0);
7781 value_from_longest (builtin_type_int
,
7782 (value_less (arg1
, arg3
)
7783 || value_equal (arg1
, arg3
))
7784 && (value_less (arg2
, arg1
)
7785 || value_equal (arg2
, arg1
)));
7787 case TERNOP_IN_RANGE
:
7788 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7789 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7790 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7792 if (noside
== EVAL_SKIP
)
7796 value_from_longest (builtin_type_int
,
7797 (value_less (arg1
, arg3
)
7798 || value_equal (arg1
, arg3
))
7799 && (value_less (arg2
, arg1
)
7800 || value_equal (arg2
, arg1
)));
7806 struct type
*type_arg
;
7807 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
7809 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7811 type_arg
= exp
->elts
[pc
+ 2].type
;
7815 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7819 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
7820 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
7821 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
7824 if (noside
== EVAL_SKIP
)
7827 if (type_arg
== NULL
)
7829 arg1
= ada_coerce_ref (arg1
);
7831 if (ada_is_packed_array_type (value_type (arg1
)))
7832 arg1
= ada_coerce_to_simple_array (arg1
);
7834 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
7835 error (_("invalid dimension number to '%s"),
7836 ada_attribute_name (op
));
7838 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7840 type
= ada_index_type (value_type (arg1
), tem
);
7843 (_("attempt to take bound of something that is not an array"));
7844 return allocate_value (type
);
7849 default: /* Should never happen. */
7850 error (_("unexpected attribute encountered"));
7852 return ada_array_bound (arg1
, tem
, 0);
7854 return ada_array_bound (arg1
, tem
, 1);
7856 return ada_array_length (arg1
, tem
);
7859 else if (discrete_type_p (type_arg
))
7861 struct type
*range_type
;
7862 char *name
= ada_type_name (type_arg
);
7864 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
7866 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
7867 if (range_type
== NULL
)
7868 range_type
= type_arg
;
7872 error (_("unexpected attribute encountered"));
7874 return discrete_type_low_bound (range_type
);
7876 return discrete_type_high_bound (range_type
);
7878 error (_("the 'length attribute applies only to array types"));
7881 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
7882 error (_("unimplemented type attribute"));
7887 if (ada_is_packed_array_type (type_arg
))
7888 type_arg
= decode_packed_array_type (type_arg
);
7890 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
7891 error (_("invalid dimension number to '%s"),
7892 ada_attribute_name (op
));
7894 type
= ada_index_type (type_arg
, tem
);
7897 (_("attempt to take bound of something that is not an array"));
7898 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7899 return allocate_value (type
);
7904 error (_("unexpected attribute encountered"));
7906 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7907 return value_from_longest (type
, low
);
7909 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
7910 return value_from_longest (type
, high
);
7912 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7913 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
7914 return value_from_longest (type
, high
- low
+ 1);
7920 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7921 if (noside
== EVAL_SKIP
)
7924 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7925 return value_zero (ada_tag_type (arg1
), not_lval
);
7927 return ada_value_tag (arg1
);
7931 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7932 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7933 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7934 if (noside
== EVAL_SKIP
)
7936 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7937 return value_zero (value_type (arg1
), not_lval
);
7939 return value_binop (arg1
, arg2
,
7940 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
7942 case OP_ATR_MODULUS
:
7944 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
7945 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7947 if (noside
== EVAL_SKIP
)
7950 if (!ada_is_modular_type (type_arg
))
7951 error (_("'modulus must be applied to modular type"));
7953 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
7954 ada_modulus (type_arg
));
7959 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7960 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7961 if (noside
== EVAL_SKIP
)
7963 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7964 return value_zero (builtin_type_int
, not_lval
);
7966 return value_pos_atr (arg1
);
7969 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7970 if (noside
== EVAL_SKIP
)
7972 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7973 return value_zero (builtin_type_int
, not_lval
);
7975 return value_from_longest (builtin_type_int
,
7977 * TYPE_LENGTH (value_type (arg1
)));
7980 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7981 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7982 type
= exp
->elts
[pc
+ 2].type
;
7983 if (noside
== EVAL_SKIP
)
7985 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7986 return value_zero (type
, not_lval
);
7988 return value_val_atr (type
, arg1
);
7991 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7992 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7993 if (noside
== EVAL_SKIP
)
7995 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7996 return value_zero (value_type (arg1
), not_lval
);
7998 return value_binop (arg1
, arg2
, op
);
8001 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8002 if (noside
== EVAL_SKIP
)
8008 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8009 if (noside
== EVAL_SKIP
)
8011 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
8012 return value_neg (arg1
);
8017 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
8018 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
8019 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
8020 if (noside
== EVAL_SKIP
)
8022 type
= ada_check_typedef (value_type (arg1
));
8023 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8025 if (ada_is_array_descriptor_type (type
))
8026 /* GDB allows dereferencing GNAT array descriptors. */
8028 struct type
*arrType
= ada_type_of_array (arg1
, 0);
8029 if (arrType
== NULL
)
8030 error (_("Attempt to dereference null array pointer."));
8031 return value_at_lazy (arrType
, 0);
8033 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
8034 || TYPE_CODE (type
) == TYPE_CODE_REF
8035 /* In C you can dereference an array to get the 1st elt. */
8036 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8038 type
= to_static_fixed_type
8040 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
8042 return value_zero (type
, lval_memory
);
8044 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
8045 /* GDB allows dereferencing an int. */
8046 return value_zero (builtin_type_int
, lval_memory
);
8048 error (_("Attempt to take contents of a non-pointer value."));
8050 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
8051 type
= ada_check_typedef (value_type (arg1
));
8053 if (ada_is_array_descriptor_type (type
))
8054 /* GDB allows dereferencing GNAT array descriptors. */
8055 return ada_coerce_to_simple_array (arg1
);
8057 return ada_value_ind (arg1
);
8059 case STRUCTOP_STRUCT
:
8060 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8061 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
8062 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8063 if (noside
== EVAL_SKIP
)
8065 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8067 struct type
*type1
= value_type (arg1
);
8068 if (ada_is_tagged_type (type1
, 1))
8070 type
= ada_lookup_struct_elt_type (type1
,
8071 &exp
->elts
[pc
+ 2].string
,
8074 /* In this case, we assume that the field COULD exist
8075 in some extension of the type. Return an object of
8076 "type" void, which will match any formal
8077 (see ada_type_match). */
8078 return value_zero (builtin_type_void
, lval_memory
);
8082 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
8085 return value_zero (ada_aligned_type (type
), lval_memory
);
8089 ada_to_fixed_value (unwrap_value
8090 (ada_value_struct_elt
8091 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
8093 /* The value is not supposed to be used. This is here to make it
8094 easier to accommodate expressions that contain types. */
8096 if (noside
== EVAL_SKIP
)
8098 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8099 return allocate_value (builtin_type_void
);
8101 error (_("Attempt to use a type name as an expression"));
8105 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
8111 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
8112 type name that encodes the 'small and 'delta information.
8113 Otherwise, return NULL. */
8116 fixed_type_info (struct type
*type
)
8118 const char *name
= ada_type_name (type
);
8119 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
8121 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
8123 const char *tail
= strstr (name
, "___XF_");
8129 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
8130 return fixed_type_info (TYPE_TARGET_TYPE (type
));
8135 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
8138 ada_is_fixed_point_type (struct type
*type
)
8140 return fixed_type_info (type
) != NULL
;
8143 /* Return non-zero iff TYPE represents a System.Address type. */
8146 ada_is_system_address_type (struct type
*type
)
8148 return (TYPE_NAME (type
)
8149 && strcmp (TYPE_NAME (type
), "system__address") == 0);
8152 /* Assuming that TYPE is the representation of an Ada fixed-point
8153 type, return its delta, or -1 if the type is malformed and the
8154 delta cannot be determined. */
8157 ada_delta (struct type
*type
)
8159 const char *encoding
= fixed_type_info (type
);
8162 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
8165 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
8168 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
8169 factor ('SMALL value) associated with the type. */
8172 scaling_factor (struct type
*type
)
8174 const char *encoding
= fixed_type_info (type
);
8175 unsigned long num0
, den0
, num1
, den1
;
8178 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
8183 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
8185 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
8189 /* Assuming that X is the representation of a value of fixed-point
8190 type TYPE, return its floating-point equivalent. */
8193 ada_fixed_to_float (struct type
*type
, LONGEST x
)
8195 return (DOUBLEST
) x
*scaling_factor (type
);
8198 /* The representation of a fixed-point value of type TYPE
8199 corresponding to the value X. */
8202 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
8204 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
8208 /* VAX floating formats */
8210 /* Non-zero iff TYPE represents one of the special VAX floating-point
8214 ada_is_vax_floating_type (struct type
*type
)
8217 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
8220 && (TYPE_CODE (type
) == TYPE_CODE_INT
8221 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8222 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
8225 /* The type of special VAX floating-point type this is, assuming
8226 ada_is_vax_floating_point. */
8229 ada_vax_float_type_suffix (struct type
*type
)
8231 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
8234 /* A value representing the special debugging function that outputs
8235 VAX floating-point values of the type represented by TYPE. Assumes
8236 ada_is_vax_floating_type (TYPE). */
8239 ada_vax_float_print_function (struct type
*type
)
8241 switch (ada_vax_float_type_suffix (type
))
8244 return get_var_value ("DEBUG_STRING_F", 0);
8246 return get_var_value ("DEBUG_STRING_D", 0);
8248 return get_var_value ("DEBUG_STRING_G", 0);
8250 error (_("invalid VAX floating-point type"));
8257 /* Scan STR beginning at position K for a discriminant name, and
8258 return the value of that discriminant field of DVAL in *PX. If
8259 PNEW_K is not null, put the position of the character beyond the
8260 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8261 not alter *PX and *PNEW_K if unsuccessful. */
8264 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
8267 static char *bound_buffer
= NULL
;
8268 static size_t bound_buffer_len
= 0;
8271 struct value
*bound_val
;
8273 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
8276 pend
= strstr (str
+ k
, "__");
8280 k
+= strlen (bound
);
8284 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
8285 bound
= bound_buffer
;
8286 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
8287 bound
[pend
- (str
+ k
)] = '\0';
8291 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
8292 if (bound_val
== NULL
)
8295 *px
= value_as_long (bound_val
);
8301 /* Value of variable named NAME in the current environment. If
8302 no such variable found, then if ERR_MSG is null, returns 0, and
8303 otherwise causes an error with message ERR_MSG. */
8305 static struct value
*
8306 get_var_value (char *name
, char *err_msg
)
8308 struct ada_symbol_info
*syms
;
8311 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
8316 if (err_msg
== NULL
)
8319 error (("%s"), err_msg
);
8322 return value_of_variable (syms
[0].sym
, syms
[0].block
);
8325 /* Value of integer variable named NAME in the current environment. If
8326 no such variable found, returns 0, and sets *FLAG to 0. If
8327 successful, sets *FLAG to 1. */
8330 get_int_var_value (char *name
, int *flag
)
8332 struct value
*var_val
= get_var_value (name
, 0);
8344 return value_as_long (var_val
);
8349 /* Return a range type whose base type is that of the range type named
8350 NAME in the current environment, and whose bounds are calculated
8351 from NAME according to the GNAT range encoding conventions.
8352 Extract discriminant values, if needed, from DVAL. If a new type
8353 must be created, allocate in OBJFILE's space. The bounds
8354 information, in general, is encoded in NAME, the base type given in
8355 the named range type. */
8357 static struct type
*
8358 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
8360 struct type
*raw_type
= ada_find_any_type (name
);
8361 struct type
*base_type
;
8364 if (raw_type
== NULL
)
8365 base_type
= builtin_type_int
;
8366 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
8367 base_type
= TYPE_TARGET_TYPE (raw_type
);
8369 base_type
= raw_type
;
8371 subtype_info
= strstr (name
, "___XD");
8372 if (subtype_info
== NULL
)
8376 static char *name_buf
= NULL
;
8377 static size_t name_len
= 0;
8378 int prefix_len
= subtype_info
- name
;
8384 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
8385 strncpy (name_buf
, name
, prefix_len
);
8386 name_buf
[prefix_len
] = '\0';
8389 bounds_str
= strchr (subtype_info
, '_');
8392 if (*subtype_info
== 'L')
8394 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
8395 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
8397 if (bounds_str
[n
] == '_')
8399 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
8406 strcpy (name_buf
+ prefix_len
, "___L");
8407 L
= get_int_var_value (name_buf
, &ok
);
8410 lim_warning (_("Unknown lower bound, using 1."));
8415 if (*subtype_info
== 'U')
8417 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
8418 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
8424 strcpy (name_buf
+ prefix_len
, "___U");
8425 U
= get_int_var_value (name_buf
, &ok
);
8428 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
8433 if (objfile
== NULL
)
8434 objfile
= TYPE_OBJFILE (base_type
);
8435 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
8436 TYPE_NAME (type
) = name
;
8441 /* True iff NAME is the name of a range type. */
8444 ada_is_range_type_name (const char *name
)
8446 return (name
!= NULL
&& strstr (name
, "___XD"));
8452 /* True iff TYPE is an Ada modular type. */
8455 ada_is_modular_type (struct type
*type
)
8457 struct type
*subranged_type
= base_type (type
);
8459 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
8460 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
8461 && TYPE_UNSIGNED (subranged_type
));
8464 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8467 ada_modulus (struct type
* type
)
8469 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
8473 /* Information about operators given special treatment in functions
8475 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
8477 #define ADA_OPERATORS \
8478 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
8479 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
8480 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
8481 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
8482 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
8483 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
8484 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
8485 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
8486 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
8487 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
8488 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
8489 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
8490 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
8491 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
8492 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
8493 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
8496 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
8498 switch (exp
->elts
[pc
- 1].opcode
)
8501 operator_length_standard (exp
, pc
, oplenp
, argsp
);
8504 #define OP_DEFN(op, len, args, binop) \
8505 case op: *oplenp = len; *argsp = args; break;
8512 ada_op_name (enum exp_opcode opcode
)
8517 return op_name_standard (opcode
);
8518 #define OP_DEFN(op, len, args, binop) case op: return #op;
8524 /* As for operator_length, but assumes PC is pointing at the first
8525 element of the operator, and gives meaningful results only for the
8526 Ada-specific operators. */
8529 ada_forward_operator_length (struct expression
*exp
, int pc
,
8530 int *oplenp
, int *argsp
)
8532 switch (exp
->elts
[pc
].opcode
)
8535 *oplenp
= *argsp
= 0;
8537 #define OP_DEFN(op, len, args, binop) \
8538 case op: *oplenp = len; *argsp = args; break;
8545 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
8547 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
8552 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
8556 /* Ada attributes ('Foo). */
8563 case OP_ATR_MODULUS
:
8572 /* XXX: gdb_sprint_host_address, type_sprint */
8573 fprintf_filtered (stream
, _("Type @"));
8574 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
8575 fprintf_filtered (stream
, " (");
8576 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
8577 fprintf_filtered (stream
, ")");
8579 case BINOP_IN_BOUNDS
:
8580 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
8582 case TERNOP_IN_RANGE
:
8586 return dump_subexp_body_standard (exp
, stream
, elt
);
8590 for (i
= 0; i
< nargs
; i
+= 1)
8591 elt
= dump_subexp (exp
, stream
, elt
);
8596 /* The Ada extension of print_subexp (q.v.). */
8599 ada_print_subexp (struct expression
*exp
, int *pos
,
8600 struct ui_file
*stream
, enum precedence prec
)
8604 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
8606 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8611 print_subexp_standard (exp
, pos
, stream
, prec
);
8616 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
8619 case BINOP_IN_BOUNDS
:
8620 /* XXX: sprint_subexp */
8622 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8623 fputs_filtered (" in ", stream
);
8624 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8625 fputs_filtered ("'range", stream
);
8626 if (exp
->elts
[pc
+ 1].longconst
> 1)
8627 fprintf_filtered (stream
, "(%ld)",
8628 (long) exp
->elts
[pc
+ 1].longconst
);
8631 case TERNOP_IN_RANGE
:
8633 if (prec
>= PREC_EQUAL
)
8634 fputs_filtered ("(", stream
);
8635 /* XXX: sprint_subexp */
8636 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8637 fputs_filtered (" in ", stream
);
8638 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8639 fputs_filtered (" .. ", stream
);
8640 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8641 if (prec
>= PREC_EQUAL
)
8642 fputs_filtered (")", stream
);
8651 case OP_ATR_MODULUS
:
8657 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8659 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
8660 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
8664 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8665 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
8669 for (tem
= 1; tem
< nargs
; tem
+= 1)
8671 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
8672 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
8674 fputs_filtered (")", stream
);
8680 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
8681 fputs_filtered ("'(", stream
);
8682 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
8683 fputs_filtered (")", stream
);
8688 /* XXX: sprint_subexp */
8689 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8690 fputs_filtered (" in ", stream
);
8691 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
8696 /* Table mapping opcodes into strings for printing operators
8697 and precedences of the operators. */
8699 static const struct op_print ada_op_print_tab
[] = {
8700 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
8701 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
8702 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
8703 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
8704 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
8705 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
8706 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
8707 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
8708 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
8709 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
8710 {">", BINOP_GTR
, PREC_ORDER
, 0},
8711 {"<", BINOP_LESS
, PREC_ORDER
, 0},
8712 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
8713 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
8714 {"+", BINOP_ADD
, PREC_ADD
, 0},
8715 {"-", BINOP_SUB
, PREC_ADD
, 0},
8716 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8717 {"*", BINOP_MUL
, PREC_MUL
, 0},
8718 {"/", BINOP_DIV
, PREC_MUL
, 0},
8719 {"rem", BINOP_REM
, PREC_MUL
, 0},
8720 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8721 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8722 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8723 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8724 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8725 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8726 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8727 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8728 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
8729 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
8730 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
8734 /* Fundamental Ada Types */
8736 /* Create a fundamental Ada type using default reasonable for the current
8739 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8740 define fundamental types such as "int" or "double". Others (stabs or
8741 DWARF version 2, etc) do define fundamental types. For the formats which
8742 don't provide fundamental types, gdb can create such types using this
8745 FIXME: Some compilers distinguish explicitly signed integral types
8746 (signed short, signed int, signed long) from "regular" integral types
8747 (short, int, long) in the debugging information. There is some dis-
8748 agreement as to how useful this feature is. In particular, gcc does
8749 not support this. Also, only some debugging formats allow the
8750 distinction to be passed on to a debugger. For now, we always just
8751 use "short", "int", or "long" as the type name, for both the implicit
8752 and explicitly signed types. This also makes life easier for the
8753 gdb test suite since we don't have to account for the differences
8754 in output depending upon what the compiler and debugging format
8755 support. We will probably have to re-examine the issue when gdb
8756 starts taking it's fundamental type information directly from the
8757 debugging information supplied by the compiler. fnf@cygnus.com */
8759 static struct type
*
8760 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8762 struct type
*type
= NULL
;
8767 /* FIXME: For now, if we are asked to produce a type not in this
8768 language, create the equivalent of a C integer type with the
8769 name "<?type?>". When all the dust settles from the type
8770 reconstruction work, this should probably become an error. */
8771 type
= init_type (TYPE_CODE_INT
,
8772 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8773 0, "<?type?>", objfile
);
8774 warning (_("internal error: no Ada fundamental type %d"), typeid);
8777 type
= init_type (TYPE_CODE_VOID
,
8778 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8779 0, "void", objfile
);
8782 type
= init_type (TYPE_CODE_INT
,
8783 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8784 0, "character", objfile
);
8786 case FT_SIGNED_CHAR
:
8787 type
= init_type (TYPE_CODE_INT
,
8788 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8789 0, "signed char", objfile
);
8791 case FT_UNSIGNED_CHAR
:
8792 type
= init_type (TYPE_CODE_INT
,
8793 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8794 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8797 type
= init_type (TYPE_CODE_INT
,
8798 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8799 0, "short_integer", objfile
);
8801 case FT_SIGNED_SHORT
:
8802 type
= init_type (TYPE_CODE_INT
,
8803 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8804 0, "short_integer", objfile
);
8806 case FT_UNSIGNED_SHORT
:
8807 type
= init_type (TYPE_CODE_INT
,
8808 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8809 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8812 type
= init_type (TYPE_CODE_INT
,
8813 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8814 0, "integer", objfile
);
8816 case FT_SIGNED_INTEGER
:
8817 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/
8819 0, "integer", objfile
); /* FIXME -fnf */
8821 case FT_UNSIGNED_INTEGER
:
8822 type
= init_type (TYPE_CODE_INT
,
8823 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8824 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8827 type
= init_type (TYPE_CODE_INT
,
8828 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8829 0, "long_integer", objfile
);
8831 case FT_SIGNED_LONG
:
8832 type
= init_type (TYPE_CODE_INT
,
8833 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8834 0, "long_integer", objfile
);
8836 case FT_UNSIGNED_LONG
:
8837 type
= init_type (TYPE_CODE_INT
,
8838 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8839 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8842 type
= init_type (TYPE_CODE_INT
,
8843 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8844 0, "long_long_integer", objfile
);
8846 case FT_SIGNED_LONG_LONG
:
8847 type
= init_type (TYPE_CODE_INT
,
8848 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8849 0, "long_long_integer", objfile
);
8851 case FT_UNSIGNED_LONG_LONG
:
8852 type
= init_type (TYPE_CODE_INT
,
8853 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8854 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8857 type
= init_type (TYPE_CODE_FLT
,
8858 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8859 0, "float", objfile
);
8861 case FT_DBL_PREC_FLOAT
:
8862 type
= init_type (TYPE_CODE_FLT
,
8863 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8864 0, "long_float", objfile
);
8866 case FT_EXT_PREC_FLOAT
:
8867 type
= init_type (TYPE_CODE_FLT
,
8868 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8869 0, "long_long_float", objfile
);
8875 enum ada_primitive_types
{
8876 ada_primitive_type_int
,
8877 ada_primitive_type_long
,
8878 ada_primitive_type_short
,
8879 ada_primitive_type_char
,
8880 ada_primitive_type_float
,
8881 ada_primitive_type_double
,
8882 ada_primitive_type_void
,
8883 ada_primitive_type_long_long
,
8884 ada_primitive_type_long_double
,
8885 ada_primitive_type_natural
,
8886 ada_primitive_type_positive
,
8887 ada_primitive_type_system_address
,
8888 nr_ada_primitive_types
8892 ada_language_arch_info (struct gdbarch
*current_gdbarch
,
8893 struct language_arch_info
*lai
)
8895 const struct builtin_type
*builtin
= builtin_type (current_gdbarch
);
8896 lai
->primitive_type_vector
8897 = GDBARCH_OBSTACK_CALLOC (current_gdbarch
, nr_ada_primitive_types
+ 1,
8899 lai
->primitive_type_vector
[ada_primitive_type_int
] =
8900 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8901 0, "integer", (struct objfile
*) NULL
);
8902 lai
->primitive_type_vector
[ada_primitive_type_long
] =
8903 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8904 0, "long_integer", (struct objfile
*) NULL
);
8905 lai
->primitive_type_vector
[ada_primitive_type_short
] =
8906 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8907 0, "short_integer", (struct objfile
*) NULL
);
8908 lai
->string_char_type
=
8909 lai
->primitive_type_vector
[ada_primitive_type_char
] =
8910 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8911 0, "character", (struct objfile
*) NULL
);
8912 lai
->primitive_type_vector
[ada_primitive_type_float
] =
8913 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8914 0, "float", (struct objfile
*) NULL
);
8915 lai
->primitive_type_vector
[ada_primitive_type_double
] =
8916 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8917 0, "long_float", (struct objfile
*) NULL
);
8918 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
8919 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8920 0, "long_long_integer", (struct objfile
*) NULL
);
8921 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
8922 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8923 0, "long_long_float", (struct objfile
*) NULL
);
8924 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
8925 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8926 0, "natural", (struct objfile
*) NULL
);
8927 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
8928 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8929 0, "positive", (struct objfile
*) NULL
);
8930 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
8932 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
8933 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8934 (struct objfile
*) NULL
));
8935 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
8936 = "system__address";
8939 /* Language vector */
8941 /* Not really used, but needed in the ada_language_defn. */
8944 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8946 ada_emit_char (c
, stream
, quoter
, 1);
8952 warnings_issued
= 0;
8953 return ada_parse ();
8956 static const struct exp_descriptor ada_exp_descriptor
= {
8958 ada_operator_length
,
8960 ada_dump_subexp_body
,
8964 const struct language_defn ada_language_defn
= {
8965 "ada", /* Language name */
8970 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8971 that's not quite what this means. */
8973 &ada_exp_descriptor
,
8977 ada_printchar
, /* Print a character constant */
8978 ada_printstr
, /* Function to print string constant */
8979 emit_char
, /* Function to print single char (not used) */
8980 ada_create_fundamental_type
, /* Create fundamental type in this language */
8981 ada_print_type
, /* Print a type using appropriate syntax */
8982 ada_val_print
, /* Print a value using appropriate syntax */
8983 ada_value_print
, /* Print a top-level value */
8984 NULL
, /* Language specific skip_trampoline */
8985 NULL
, /* value_of_this */
8986 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
8987 basic_lookup_transparent_type
, /* lookup_transparent_type */
8988 ada_la_decode
, /* Language specific symbol demangler */
8989 NULL
, /* Language specific class_name_from_physname */
8990 ada_op_print_tab
, /* expression operators for printing */
8991 0, /* c-style arrays */
8992 1, /* String lower bound */
8994 ada_get_gdb_completer_word_break_characters
,
8995 ada_language_arch_info
,
8996 ada_print_array_index
,
9001 _initialize_ada_language (void)
9003 add_language (&ada_language_defn
);
9005 varsize_limit
= 65536;
9007 obstack_init (&symbol_list_obstack
);
9009 decoded_names_store
= htab_create_alloc
9010 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
9011 NULL
, xcalloc
, xfree
);