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 /* When GDB stops on an unhandled exception, GDB will go up the stack until
270 if finds a frame corresponding to this function, in order to extract the
271 name of the exception that has been raised from one of the parameters. */
272 static const char process_raise_exception_name
[] =
273 "ada__exceptions__process_raise_exception";
275 /* A string that reflects the longest exception expression rewrite,
276 aside from the exception name. */
277 static const char longest_exception_template
[] =
278 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
280 /* Limit on the number of warnings to raise per expression evaluation. */
281 static int warning_limit
= 2;
283 /* Number of warning messages issued; reset to 0 by cleanups after
284 expression evaluation. */
285 static int warnings_issued
= 0;
287 static const char *known_runtime_file_name_patterns
[] = {
288 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
291 static const char *known_auxiliary_function_name_patterns
[] = {
292 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
295 /* Space for allocating results of ada_lookup_symbol_list. */
296 static struct obstack symbol_list_obstack
;
302 ada_get_gdb_completer_word_break_characters (void)
304 return ada_completer_word_break_characters
;
307 /* Print an array element index using the Ada syntax. */
310 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
311 int format
, enum val_prettyprint pretty
)
313 LA_VALUE_PRINT (index_value
, stream
, format
, pretty
);
314 fprintf_filtered (stream
, " => ");
317 /* Read the string located at ADDR from the inferior and store the
321 extract_string (CORE_ADDR addr
, char *buf
)
325 /* Loop, reading one byte at a time, until we reach the '\000'
326 end-of-string marker. */
329 target_read_memory (addr
+ char_index
* sizeof (char),
330 buf
+ char_index
* sizeof (char), sizeof (char));
333 while (buf
[char_index
- 1] != '\000');
336 /* Assuming VECT points to an array of *SIZE objects of size
337 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
338 updating *SIZE as necessary and returning the (new) array. */
341 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
343 if (*size
< min_size
)
346 if (*size
< min_size
)
348 vect
= xrealloc (vect
, *size
* element_size
);
353 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
354 suffix of FIELD_NAME beginning "___". */
357 field_name_match (const char *field_name
, const char *target
)
359 int len
= strlen (target
);
361 (strncmp (field_name
, target
, len
) == 0
362 && (field_name
[len
] == '\0'
363 || (strncmp (field_name
+ len
, "___", 3) == 0
364 && strcmp (field_name
+ strlen (field_name
) - 6,
369 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
370 FIELD_NAME, and return its index. This function also handles fields
371 whose name have ___ suffixes because the compiler sometimes alters
372 their name by adding such a suffix to represent fields with certain
373 constraints. If the field could not be found, return a negative
374 number if MAYBE_MISSING is set. Otherwise raise an error. */
377 ada_get_field_index (const struct type
*type
, const char *field_name
,
381 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
382 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
386 error (_("Unable to find field %s in struct %s. Aborting"),
387 field_name
, TYPE_NAME (type
));
392 /* The length of the prefix of NAME prior to any "___" suffix. */
395 ada_name_prefix_len (const char *name
)
401 const char *p
= strstr (name
, "___");
403 return strlen (name
);
409 /* Return non-zero if SUFFIX is a suffix of STR.
410 Return zero if STR is null. */
413 is_suffix (const char *str
, const char *suffix
)
419 len2
= strlen (suffix
);
420 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
423 /* Create a value of type TYPE whose contents come from VALADDR, if it
424 is non-null, and whose memory address (in the inferior) is
428 value_from_contents_and_address (struct type
*type
,
429 const gdb_byte
*valaddr
,
432 struct value
*v
= allocate_value (type
);
434 set_value_lazy (v
, 1);
436 memcpy (value_contents_raw (v
), valaddr
, TYPE_LENGTH (type
));
437 VALUE_ADDRESS (v
) = address
;
439 VALUE_LVAL (v
) = lval_memory
;
443 /* The contents of value VAL, treated as a value of type TYPE. The
444 result is an lval in memory if VAL is. */
446 static struct value
*
447 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
449 type
= ada_check_typedef (type
);
450 if (value_type (val
) == type
)
454 struct value
*result
;
456 /* Make sure that the object size is not unreasonable before
457 trying to allocate some memory for it. */
460 result
= allocate_value (type
);
461 VALUE_LVAL (result
) = VALUE_LVAL (val
);
462 set_value_bitsize (result
, value_bitsize (val
));
463 set_value_bitpos (result
, value_bitpos (val
));
464 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + value_offset (val
);
466 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
467 set_value_lazy (result
, 1);
469 memcpy (value_contents_raw (result
), value_contents (val
),
475 static const gdb_byte
*
476 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
481 return valaddr
+ offset
;
485 cond_offset_target (CORE_ADDR address
, long offset
)
490 return address
+ offset
;
493 /* Issue a warning (as for the definition of warning in utils.c, but
494 with exactly one argument rather than ...), unless the limit on the
495 number of warnings has passed during the evaluation of the current
498 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
499 provided by "complaint". */
500 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
503 lim_warning (const char *format
, ...)
506 va_start (args
, format
);
508 warnings_issued
+= 1;
509 if (warnings_issued
<= warning_limit
)
510 vwarning (format
, args
);
515 /* Issue an error if the size of an object of type T is unreasonable,
516 i.e. if it would be a bad idea to allocate a value of this type in
520 check_size (const struct type
*type
)
522 if (TYPE_LENGTH (type
) > varsize_limit
)
523 error (_("object size is larger than varsize-limit"));
527 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
528 gdbtypes.h, but some of the necessary definitions in that file
529 seem to have gone missing. */
531 /* Maximum value of a SIZE-byte signed integer type. */
533 max_of_size (int size
)
535 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
536 return top_bit
| (top_bit
- 1);
539 /* Minimum value of a SIZE-byte signed integer type. */
541 min_of_size (int size
)
543 return -max_of_size (size
) - 1;
546 /* Maximum value of a SIZE-byte unsigned integer type. */
548 umax_of_size (int size
)
550 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
551 return top_bit
| (top_bit
- 1);
554 /* Maximum value of integral type T, as a signed quantity. */
556 max_of_type (struct type
*t
)
558 if (TYPE_UNSIGNED (t
))
559 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
561 return max_of_size (TYPE_LENGTH (t
));
564 /* Minimum value of integral type T, as a signed quantity. */
566 min_of_type (struct type
*t
)
568 if (TYPE_UNSIGNED (t
))
571 return min_of_size (TYPE_LENGTH (t
));
574 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
575 static struct value
*
576 discrete_type_high_bound (struct type
*type
)
578 switch (TYPE_CODE (type
))
580 case TYPE_CODE_RANGE
:
581 return value_from_longest (TYPE_TARGET_TYPE (type
),
582 TYPE_HIGH_BOUND (type
));
585 value_from_longest (type
,
586 TYPE_FIELD_BITPOS (type
,
587 TYPE_NFIELDS (type
) - 1));
589 return value_from_longest (type
, max_of_type (type
));
591 error (_("Unexpected type in discrete_type_high_bound."));
595 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
596 static struct value
*
597 discrete_type_low_bound (struct type
*type
)
599 switch (TYPE_CODE (type
))
601 case TYPE_CODE_RANGE
:
602 return value_from_longest (TYPE_TARGET_TYPE (type
),
603 TYPE_LOW_BOUND (type
));
605 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
607 return value_from_longest (type
, min_of_type (type
));
609 error (_("Unexpected type in discrete_type_low_bound."));
613 /* The identity on non-range types. For range types, the underlying
614 non-range scalar type. */
617 base_type (struct type
*type
)
619 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
621 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
623 type
= TYPE_TARGET_TYPE (type
);
629 /* Language Selection */
631 /* If the main program is in Ada, return language_ada, otherwise return LANG
632 (the main program is in Ada iif the adainit symbol is found).
634 MAIN_PST is not used. */
637 ada_update_initial_language (enum language lang
,
638 struct partial_symtab
*main_pst
)
640 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
641 (struct objfile
*) NULL
) != NULL
)
647 /* If the main procedure is written in Ada, then return its name.
648 The result is good until the next call. Return NULL if the main
649 procedure doesn't appear to be in Ada. */
654 struct minimal_symbol
*msym
;
655 CORE_ADDR main_program_name_addr
;
656 static char main_program_name
[1024];
658 /* For Ada, the name of the main procedure is stored in a specific
659 string constant, generated by the binder. Look for that symbol,
660 extract its address, and then read that string. If we didn't find
661 that string, then most probably the main procedure is not written
663 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
667 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
668 if (main_program_name_addr
== 0)
669 error (_("Invalid address for Ada main program name."));
671 extract_string (main_program_name_addr
, main_program_name
);
672 return main_program_name
;
675 /* The main procedure doesn't seem to be in Ada. */
681 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
684 const struct ada_opname_map ada_opname_table
[] = {
685 {"Oadd", "\"+\"", BINOP_ADD
},
686 {"Osubtract", "\"-\"", BINOP_SUB
},
687 {"Omultiply", "\"*\"", BINOP_MUL
},
688 {"Odivide", "\"/\"", BINOP_DIV
},
689 {"Omod", "\"mod\"", BINOP_MOD
},
690 {"Orem", "\"rem\"", BINOP_REM
},
691 {"Oexpon", "\"**\"", BINOP_EXP
},
692 {"Olt", "\"<\"", BINOP_LESS
},
693 {"Ole", "\"<=\"", BINOP_LEQ
},
694 {"Ogt", "\">\"", BINOP_GTR
},
695 {"Oge", "\">=\"", BINOP_GEQ
},
696 {"Oeq", "\"=\"", BINOP_EQUAL
},
697 {"One", "\"/=\"", BINOP_NOTEQUAL
},
698 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
699 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
700 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
701 {"Oconcat", "\"&\"", BINOP_CONCAT
},
702 {"Oabs", "\"abs\"", UNOP_ABS
},
703 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
704 {"Oadd", "\"+\"", UNOP_PLUS
},
705 {"Osubtract", "\"-\"", UNOP_NEG
},
709 /* Return non-zero if STR should be suppressed in info listings. */
712 is_suppressed_name (const char *str
)
714 if (strncmp (str
, "_ada_", 5) == 0)
716 if (str
[0] == '_' || str
[0] == '\000')
721 const char *suffix
= strstr (str
, "___");
722 if (suffix
!= NULL
&& suffix
[3] != 'X')
725 suffix
= str
+ strlen (str
);
726 for (p
= suffix
- 1; p
!= str
; p
-= 1)
730 if (p
[0] == 'X' && p
[-1] != '_')
734 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
735 if (strncmp (ada_opname_table
[i
].encoded
, p
,
736 strlen (ada_opname_table
[i
].encoded
)) == 0)
745 /* The "encoded" form of DECODED, according to GNAT conventions.
746 The result is valid until the next call to ada_encode. */
749 ada_encode (const char *decoded
)
751 static char *encoding_buffer
= NULL
;
752 static size_t encoding_buffer_size
= 0;
759 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
760 2 * strlen (decoded
) + 10);
763 for (p
= decoded
; *p
!= '\0'; p
+= 1)
765 if (!ADA_RETAIN_DOTS
&& *p
== '.')
767 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
772 const struct ada_opname_map
*mapping
;
774 for (mapping
= ada_opname_table
;
775 mapping
->encoded
!= NULL
776 && strncmp (mapping
->decoded
, p
,
777 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
779 if (mapping
->encoded
== NULL
)
780 error (_("invalid Ada operator name: %s"), p
);
781 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
782 k
+= strlen (mapping
->encoded
);
787 encoding_buffer
[k
] = *p
;
792 encoding_buffer
[k
] = '\0';
793 return encoding_buffer
;
796 /* Return NAME folded to lower case, or, if surrounded by single
797 quotes, unfolded, but with the quotes stripped away. Result good
801 ada_fold_name (const char *name
)
803 static char *fold_buffer
= NULL
;
804 static size_t fold_buffer_size
= 0;
806 int len
= strlen (name
);
807 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
811 strncpy (fold_buffer
, name
+ 1, len
- 2);
812 fold_buffer
[len
- 2] = '\000';
817 for (i
= 0; i
<= len
; i
+= 1)
818 fold_buffer
[i
] = tolower (name
[i
]);
825 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
826 These are suffixes introduced by GNAT5 to nested subprogram
827 names, and do not serve any purpose for the debugger.
828 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
829 2. Convert other instances of embedded "__" to `.'.
830 3. Discard leading _ada_.
831 4. Convert operator names to the appropriate quoted symbols.
832 5. Remove everything after first ___ if it is followed by
834 6. Replace TK__ with __, and a trailing B or TKB with nothing.
835 7. Put symbols that should be suppressed in <...> brackets.
836 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
838 The resulting string is valid until the next call of ada_decode.
839 If the string is unchanged by demangling, the original string pointer
843 ada_decode (const char *encoded
)
850 static char *decoding_buffer
= NULL
;
851 static size_t decoding_buffer_size
= 0;
853 if (strncmp (encoded
, "_ada_", 5) == 0)
856 if (encoded
[0] == '_' || encoded
[0] == '<')
859 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
860 len0
= strlen (encoded
);
861 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
864 while (i
> 0 && isdigit (encoded
[i
]))
866 if (i
>= 0 && encoded
[i
] == '.')
868 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
872 /* Remove the ___X.* suffix if present. Do not forget to verify that
873 the suffix is located before the current "end" of ENCODED. We want
874 to avoid re-matching parts of ENCODED that have previously been
875 marked as discarded (by decrementing LEN0). */
876 p
= strstr (encoded
, "___");
877 if (p
!= NULL
&& p
- encoded
< len0
- 3)
885 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
888 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
891 /* Make decoded big enough for possible expansion by operator name. */
892 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
893 decoded
= decoding_buffer
;
895 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
898 while ((i
>= 0 && isdigit (encoded
[i
]))
899 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
901 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
903 else if (encoded
[i
] == '$')
907 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
908 decoded
[j
] = encoded
[i
];
913 if (at_start_name
&& encoded
[i
] == 'O')
916 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
918 int op_len
= strlen (ada_opname_table
[k
].encoded
);
919 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
921 && !isalnum (encoded
[i
+ op_len
]))
923 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
926 j
+= strlen (ada_opname_table
[k
].decoded
);
930 if (ada_opname_table
[k
].encoded
!= NULL
)
935 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
937 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
941 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
945 else if (!ADA_RETAIN_DOTS
946 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
955 decoded
[j
] = encoded
[i
];
962 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
963 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
966 if (strcmp (decoded
, encoded
) == 0)
972 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
973 decoded
= decoding_buffer
;
974 if (encoded
[0] == '<')
975 strcpy (decoded
, encoded
);
977 sprintf (decoded
, "<%s>", encoded
);
982 /* Table for keeping permanent unique copies of decoded names. Once
983 allocated, names in this table are never released. While this is a
984 storage leak, it should not be significant unless there are massive
985 changes in the set of decoded names in successive versions of a
986 symbol table loaded during a single session. */
987 static struct htab
*decoded_names_store
;
989 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
990 in the language-specific part of GSYMBOL, if it has not been
991 previously computed. Tries to save the decoded name in the same
992 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
993 in any case, the decoded symbol has a lifetime at least that of
995 The GSYMBOL parameter is "mutable" in the C++ sense: logically
996 const, but nevertheless modified to a semantically equivalent form
997 when a decoded name is cached in it.
1001 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1004 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1005 if (*resultp
== NULL
)
1007 const char *decoded
= ada_decode (gsymbol
->name
);
1008 if (gsymbol
->bfd_section
!= NULL
)
1010 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
1013 struct objfile
*objf
;
1016 if (obfd
== objf
->obfd
)
1018 *resultp
= obsavestring (decoded
, strlen (decoded
),
1019 &objf
->objfile_obstack
);
1025 /* Sometimes, we can't find a corresponding objfile, in which
1026 case, we put the result on the heap. Since we only decode
1027 when needed, we hope this usually does not cause a
1028 significant memory leak (FIXME). */
1029 if (*resultp
== NULL
)
1031 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1034 *slot
= xstrdup (decoded
);
1043 ada_la_decode (const char *encoded
, int options
)
1045 return xstrdup (ada_decode (encoded
));
1048 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1049 suffixes that encode debugging information or leading _ada_ on
1050 SYM_NAME (see is_name_suffix commentary for the debugging
1051 information that is ignored). If WILD, then NAME need only match a
1052 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1053 either argument is NULL. */
1056 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1058 if (sym_name
== NULL
|| name
== NULL
)
1061 return wild_match (name
, strlen (name
), sym_name
);
1064 int len_name
= strlen (name
);
1065 return (strncmp (sym_name
, name
, len_name
) == 0
1066 && is_name_suffix (sym_name
+ len_name
))
1067 || (strncmp (sym_name
, "_ada_", 5) == 0
1068 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1069 && is_name_suffix (sym_name
+ len_name
+ 5));
1073 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1074 suppressed in info listings. */
1077 ada_suppress_symbol_printing (struct symbol
*sym
)
1079 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1082 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1088 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1090 static char *bound_name
[] = {
1091 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1092 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1095 /* Maximum number of array dimensions we are prepared to handle. */
1097 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1099 /* Like modify_field, but allows bitpos > wordlength. */
1102 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1104 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1108 /* The desc_* routines return primitive portions of array descriptors
1111 /* The descriptor or array type, if any, indicated by TYPE; removes
1112 level of indirection, if needed. */
1114 static struct type
*
1115 desc_base_type (struct type
*type
)
1119 type
= ada_check_typedef (type
);
1121 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1122 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1123 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1128 /* True iff TYPE indicates a "thin" array pointer type. */
1131 is_thin_pntr (struct type
*type
)
1134 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1135 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1138 /* The descriptor type for thin pointer type TYPE. */
1140 static struct type
*
1141 thin_descriptor_type (struct type
*type
)
1143 struct type
*base_type
= desc_base_type (type
);
1144 if (base_type
== NULL
)
1146 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1150 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1151 if (alt_type
== NULL
)
1158 /* A pointer to the array data for thin-pointer value VAL. */
1160 static struct value
*
1161 thin_data_pntr (struct value
*val
)
1163 struct type
*type
= value_type (val
);
1164 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1165 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1168 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1169 VALUE_ADDRESS (val
) + value_offset (val
));
1172 /* True iff TYPE indicates a "thick" array pointer type. */
1175 is_thick_pntr (struct type
*type
)
1177 type
= desc_base_type (type
);
1178 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1179 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1182 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1183 pointer to one, the type of its bounds data; otherwise, NULL. */
1185 static struct type
*
1186 desc_bounds_type (struct type
*type
)
1190 type
= desc_base_type (type
);
1194 else if (is_thin_pntr (type
))
1196 type
= thin_descriptor_type (type
);
1199 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1201 return ada_check_typedef (r
);
1203 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1205 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1207 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1212 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1213 one, a pointer to its bounds data. Otherwise NULL. */
1215 static struct value
*
1216 desc_bounds (struct value
*arr
)
1218 struct type
*type
= ada_check_typedef (value_type (arr
));
1219 if (is_thin_pntr (type
))
1221 struct type
*bounds_type
=
1222 desc_bounds_type (thin_descriptor_type (type
));
1225 if (desc_bounds_type
== NULL
)
1226 error (_("Bad GNAT array descriptor"));
1228 /* NOTE: The following calculation is not really kosher, but
1229 since desc_type is an XVE-encoded type (and shouldn't be),
1230 the correct calculation is a real pain. FIXME (and fix GCC). */
1231 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1232 addr
= value_as_long (arr
);
1234 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1237 value_from_longest (lookup_pointer_type (bounds_type
),
1238 addr
- TYPE_LENGTH (bounds_type
));
1241 else if (is_thick_pntr (type
))
1242 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1243 _("Bad GNAT array descriptor"));
1248 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1249 position of the field containing the address of the bounds data. */
1252 fat_pntr_bounds_bitpos (struct type
*type
)
1254 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1257 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1258 size of the field containing the address of the bounds data. */
1261 fat_pntr_bounds_bitsize (struct type
*type
)
1263 type
= desc_base_type (type
);
1265 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1266 return TYPE_FIELD_BITSIZE (type
, 1);
1268 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1271 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1272 pointer to one, the type of its array data (a
1273 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1274 ada_type_of_array to get an array type with bounds data. */
1276 static struct type
*
1277 desc_data_type (struct type
*type
)
1279 type
= desc_base_type (type
);
1281 /* NOTE: The following is bogus; see comment in desc_bounds. */
1282 if (is_thin_pntr (type
))
1283 return lookup_pointer_type
1284 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1285 else if (is_thick_pntr (type
))
1286 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1291 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1294 static struct value
*
1295 desc_data (struct value
*arr
)
1297 struct type
*type
= value_type (arr
);
1298 if (is_thin_pntr (type
))
1299 return thin_data_pntr (arr
);
1300 else if (is_thick_pntr (type
))
1301 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1302 _("Bad GNAT array descriptor"));
1308 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1309 position of the field containing the address of the data. */
1312 fat_pntr_data_bitpos (struct type
*type
)
1314 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1317 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1318 size of the field containing the address of the data. */
1321 fat_pntr_data_bitsize (struct type
*type
)
1323 type
= desc_base_type (type
);
1325 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1326 return TYPE_FIELD_BITSIZE (type
, 0);
1328 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1331 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1332 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1333 bound, if WHICH is 1. The first bound is I=1. */
1335 static struct value
*
1336 desc_one_bound (struct value
*bounds
, int i
, int which
)
1338 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1339 _("Bad GNAT array descriptor bounds"));
1342 /* If BOUNDS is an array-bounds structure type, return the bit position
1343 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1344 bound, if WHICH is 1. The first bound is I=1. */
1347 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1349 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1352 /* If BOUNDS is an array-bounds structure type, return the bit field size
1353 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1354 bound, if WHICH is 1. The first bound is I=1. */
1357 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1359 type
= desc_base_type (type
);
1361 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1362 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1364 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1367 /* If TYPE is the type of an array-bounds structure, the type of its
1368 Ith bound (numbering from 1). Otherwise, NULL. */
1370 static struct type
*
1371 desc_index_type (struct type
*type
, int i
)
1373 type
= desc_base_type (type
);
1375 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1376 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1381 /* The number of index positions in the array-bounds type TYPE.
1382 Return 0 if TYPE is NULL. */
1385 desc_arity (struct type
*type
)
1387 type
= desc_base_type (type
);
1390 return TYPE_NFIELDS (type
) / 2;
1394 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1395 an array descriptor type (representing an unconstrained array
1399 ada_is_direct_array_type (struct type
*type
)
1403 type
= ada_check_typedef (type
);
1404 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1405 || ada_is_array_descriptor_type (type
));
1408 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1411 ada_is_simple_array_type (struct type
*type
)
1415 type
= ada_check_typedef (type
);
1416 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1417 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1418 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1421 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1424 ada_is_array_descriptor_type (struct type
*type
)
1426 struct type
*data_type
= desc_data_type (type
);
1430 type
= ada_check_typedef (type
);
1433 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1434 && TYPE_TARGET_TYPE (data_type
) != NULL
1435 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1436 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1437 && desc_arity (desc_bounds_type (type
)) > 0;
1440 /* Non-zero iff type is a partially mal-formed GNAT array
1441 descriptor. FIXME: This is to compensate for some problems with
1442 debugging output from GNAT. Re-examine periodically to see if it
1446 ada_is_bogus_array_descriptor (struct type
*type
)
1450 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1451 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1452 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1453 && !ada_is_array_descriptor_type (type
);
1457 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1458 (fat pointer) returns the type of the array data described---specifically,
1459 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1460 in from the descriptor; otherwise, they are left unspecified. If
1461 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1462 returns NULL. The result is simply the type of ARR if ARR is not
1465 ada_type_of_array (struct value
*arr
, int bounds
)
1467 if (ada_is_packed_array_type (value_type (arr
)))
1468 return decode_packed_array_type (value_type (arr
));
1470 if (!ada_is_array_descriptor_type (value_type (arr
)))
1471 return value_type (arr
);
1475 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1478 struct type
*elt_type
;
1480 struct value
*descriptor
;
1481 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1483 elt_type
= ada_array_element_type (value_type (arr
), -1);
1484 arity
= ada_array_arity (value_type (arr
));
1486 if (elt_type
== NULL
|| arity
== 0)
1487 return ada_check_typedef (value_type (arr
));
1489 descriptor
= desc_bounds (arr
);
1490 if (value_as_long (descriptor
) == 0)
1494 struct type
*range_type
= alloc_type (objf
);
1495 struct type
*array_type
= alloc_type (objf
);
1496 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1497 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1500 create_range_type (range_type
, value_type (low
),
1501 (int) value_as_long (low
),
1502 (int) value_as_long (high
));
1503 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1506 return lookup_pointer_type (elt_type
);
1510 /* If ARR does not represent an array, returns ARR unchanged.
1511 Otherwise, returns either a standard GDB array with bounds set
1512 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1513 GDB array. Returns NULL if ARR is a null fat pointer. */
1516 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1518 if (ada_is_array_descriptor_type (value_type (arr
)))
1520 struct type
*arrType
= ada_type_of_array (arr
, 1);
1521 if (arrType
== NULL
)
1523 return value_cast (arrType
, value_copy (desc_data (arr
)));
1525 else if (ada_is_packed_array_type (value_type (arr
)))
1526 return decode_packed_array (arr
);
1531 /* If ARR does not represent an array, returns ARR unchanged.
1532 Otherwise, returns a standard GDB array describing ARR (which may
1533 be ARR itself if it already is in the proper form). */
1535 static struct value
*
1536 ada_coerce_to_simple_array (struct value
*arr
)
1538 if (ada_is_array_descriptor_type (value_type (arr
)))
1540 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1542 error (_("Bounds unavailable for null array pointer."));
1543 return value_ind (arrVal
);
1545 else if (ada_is_packed_array_type (value_type (arr
)))
1546 return decode_packed_array (arr
);
1551 /* If TYPE represents a GNAT array type, return it translated to an
1552 ordinary GDB array type (possibly with BITSIZE fields indicating
1553 packing). For other types, is the identity. */
1556 ada_coerce_to_simple_array_type (struct type
*type
)
1558 struct value
*mark
= value_mark ();
1559 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1560 struct type
*result
;
1561 deprecated_set_value_type (dummy
, type
);
1562 result
= ada_type_of_array (dummy
, 0);
1563 value_free_to_mark (mark
);
1567 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1570 ada_is_packed_array_type (struct type
*type
)
1574 type
= desc_base_type (type
);
1575 type
= ada_check_typedef (type
);
1577 ada_type_name (type
) != NULL
1578 && strstr (ada_type_name (type
), "___XP") != NULL
;
1581 /* Given that TYPE is a standard GDB array type with all bounds filled
1582 in, and that the element size of its ultimate scalar constituents
1583 (that is, either its elements, or, if it is an array of arrays, its
1584 elements' elements, etc.) is *ELT_BITS, return an identical type,
1585 but with the bit sizes of its elements (and those of any
1586 constituent arrays) recorded in the BITSIZE components of its
1587 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1590 static struct type
*
1591 packed_array_type (struct type
*type
, long *elt_bits
)
1593 struct type
*new_elt_type
;
1594 struct type
*new_type
;
1595 LONGEST low_bound
, high_bound
;
1597 type
= ada_check_typedef (type
);
1598 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1601 new_type
= alloc_type (TYPE_OBJFILE (type
));
1602 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1604 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1605 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1606 TYPE_NAME (new_type
) = ada_type_name (type
);
1608 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1609 &low_bound
, &high_bound
) < 0)
1610 low_bound
= high_bound
= 0;
1611 if (high_bound
< low_bound
)
1612 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1615 *elt_bits
*= (high_bound
- low_bound
+ 1);
1616 TYPE_LENGTH (new_type
) =
1617 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1620 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1624 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1626 static struct type
*
1627 decode_packed_array_type (struct type
*type
)
1630 struct block
**blocks
;
1631 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
1632 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1633 char *tail
= strstr (raw_name
, "___XP");
1634 struct type
*shadow_type
;
1638 type
= desc_base_type (type
);
1640 memcpy (name
, raw_name
, tail
- raw_name
);
1641 name
[tail
- raw_name
] = '\000';
1643 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1644 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1646 lim_warning (_("could not find bounds information on packed array"));
1649 shadow_type
= SYMBOL_TYPE (sym
);
1651 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1653 lim_warning (_("could not understand bounds information on packed array"));
1657 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1660 (_("could not understand bit size information on packed array"));
1664 return packed_array_type (shadow_type
, &bits
);
1667 /* Given that ARR is a struct value *indicating a GNAT packed array,
1668 returns a simple array that denotes that array. Its type is a
1669 standard GDB array type except that the BITSIZEs of the array
1670 target types are set to the number of bits in each element, and the
1671 type length is set appropriately. */
1673 static struct value
*
1674 decode_packed_array (struct value
*arr
)
1678 arr
= ada_coerce_ref (arr
);
1679 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1680 arr
= ada_value_ind (arr
);
1682 type
= decode_packed_array_type (value_type (arr
));
1685 error (_("can't unpack array"));
1689 if (BITS_BIG_ENDIAN
&& ada_is_modular_type (value_type (arr
)))
1691 /* This is a (right-justified) modular type representing a packed
1692 array with no wrapper. In order to interpret the value through
1693 the (left-justified) packed array type we just built, we must
1694 first left-justify it. */
1695 int bit_size
, bit_pos
;
1698 mod
= ada_modulus (value_type (arr
)) - 1;
1705 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1706 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1707 bit_pos
/ HOST_CHAR_BIT
,
1708 bit_pos
% HOST_CHAR_BIT
,
1713 return coerce_unspec_val_to_type (arr
, type
);
1717 /* The value of the element of packed array ARR at the ARITY indices
1718 given in IND. ARR must be a simple array. */
1720 static struct value
*
1721 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1724 int bits
, elt_off
, bit_off
;
1725 long elt_total_bit_offset
;
1726 struct type
*elt_type
;
1730 elt_total_bit_offset
= 0;
1731 elt_type
= ada_check_typedef (value_type (arr
));
1732 for (i
= 0; i
< arity
; i
+= 1)
1734 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1735 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1737 (_("attempt to do packed indexing of something other than a packed array"));
1740 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1741 LONGEST lowerbound
, upperbound
;
1744 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1746 lim_warning (_("don't know bounds of array"));
1747 lowerbound
= upperbound
= 0;
1750 idx
= value_as_long (value_pos_atr (ind
[i
]));
1751 if (idx
< lowerbound
|| idx
> upperbound
)
1752 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1753 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1754 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1755 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1758 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1759 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1761 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1763 if (VALUE_LVAL (arr
) == lval_internalvar
)
1764 VALUE_LVAL (v
) = lval_internalvar_component
;
1766 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1770 /* Non-zero iff TYPE includes negative integer values. */
1773 has_negatives (struct type
*type
)
1775 switch (TYPE_CODE (type
))
1780 return !TYPE_UNSIGNED (type
);
1781 case TYPE_CODE_RANGE
:
1782 return TYPE_LOW_BOUND (type
) < 0;
1787 /* Create a new value of type TYPE from the contents of OBJ starting
1788 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1789 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1790 assigning through the result will set the field fetched from.
1791 VALADDR is ignored unless OBJ is NULL, in which case,
1792 VALADDR+OFFSET must address the start of storage containing the
1793 packed value. The value returned in this case is never an lval.
1794 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1797 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
1798 long offset
, int bit_offset
, int bit_size
,
1802 int src
, /* Index into the source area */
1803 targ
, /* Index into the target area */
1804 srcBitsLeft
, /* Number of source bits left to move */
1805 nsrc
, ntarg
, /* Number of source and target bytes */
1806 unusedLS
, /* Number of bits in next significant
1807 byte of source that are unused */
1808 accumSize
; /* Number of meaningful bits in accum */
1809 unsigned char *bytes
; /* First byte containing data to unpack */
1810 unsigned char *unpacked
;
1811 unsigned long accum
; /* Staging area for bits being transferred */
1813 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1814 /* Transmit bytes from least to most significant; delta is the direction
1815 the indices move. */
1816 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1818 type
= ada_check_typedef (type
);
1822 v
= allocate_value (type
);
1823 bytes
= (unsigned char *) (valaddr
+ offset
);
1825 else if (value_lazy (obj
))
1828 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
1829 bytes
= (unsigned char *) alloca (len
);
1830 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1834 v
= allocate_value (type
);
1835 bytes
= (unsigned char *) value_contents (obj
) + offset
;
1840 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1841 if (VALUE_LVAL (obj
) == lval_internalvar
)
1842 VALUE_LVAL (v
) = lval_internalvar_component
;
1843 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
;
1844 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
1845 set_value_bitsize (v
, bit_size
);
1846 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
1848 VALUE_ADDRESS (v
) += 1;
1849 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
1853 set_value_bitsize (v
, bit_size
);
1854 unpacked
= (unsigned char *) value_contents (v
);
1856 srcBitsLeft
= bit_size
;
1858 ntarg
= TYPE_LENGTH (type
);
1862 memset (unpacked
, 0, TYPE_LENGTH (type
));
1865 else if (BITS_BIG_ENDIAN
)
1868 if (has_negatives (type
)
1869 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1873 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1876 switch (TYPE_CODE (type
))
1878 case TYPE_CODE_ARRAY
:
1879 case TYPE_CODE_UNION
:
1880 case TYPE_CODE_STRUCT
:
1881 /* Non-scalar values must be aligned at a byte boundary... */
1883 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1884 /* ... And are placed at the beginning (most-significant) bytes
1890 targ
= TYPE_LENGTH (type
) - 1;
1896 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1899 unusedLS
= bit_offset
;
1902 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1909 /* Mask for removing bits of the next source byte that are not
1910 part of the value. */
1911 unsigned int unusedMSMask
=
1912 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1914 /* Sign-extend bits for this byte. */
1915 unsigned int signMask
= sign
& ~unusedMSMask
;
1917 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1918 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1919 if (accumSize
>= HOST_CHAR_BIT
)
1921 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1922 accumSize
-= HOST_CHAR_BIT
;
1923 accum
>>= HOST_CHAR_BIT
;
1927 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1934 accum
|= sign
<< accumSize
;
1935 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1936 accumSize
-= HOST_CHAR_BIT
;
1937 accum
>>= HOST_CHAR_BIT
;
1945 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1946 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1949 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
1950 int src_offset
, int n
)
1952 unsigned int accum
, mask
;
1953 int accum_bits
, chunk_size
;
1955 target
+= targ_offset
/ HOST_CHAR_BIT
;
1956 targ_offset
%= HOST_CHAR_BIT
;
1957 source
+= src_offset
/ HOST_CHAR_BIT
;
1958 src_offset
%= HOST_CHAR_BIT
;
1959 if (BITS_BIG_ENDIAN
)
1961 accum
= (unsigned char) *source
;
1963 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1968 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1969 accum_bits
+= HOST_CHAR_BIT
;
1971 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1974 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1975 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1978 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1980 accum_bits
-= chunk_size
;
1987 accum
= (unsigned char) *source
>> src_offset
;
1989 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1993 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1994 accum_bits
+= HOST_CHAR_BIT
;
1996 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1999 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2000 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2002 accum_bits
-= chunk_size
;
2003 accum
>>= chunk_size
;
2011 /* Store the contents of FROMVAL into the location of TOVAL.
2012 Return a new value with the location of TOVAL and contents of
2013 FROMVAL. Handles assignment into packed fields that have
2014 floating-point or non-scalar types. */
2016 static struct value
*
2017 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2019 struct type
*type
= value_type (toval
);
2020 int bits
= value_bitsize (toval
);
2022 if (!deprecated_value_modifiable (toval
))
2023 error (_("Left operand of assignment is not a modifiable lvalue."));
2025 toval
= coerce_ref (toval
);
2027 if (VALUE_LVAL (toval
) == lval_memory
2029 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2030 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2032 int len
= (value_bitpos (toval
)
2033 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2034 char *buffer
= (char *) alloca (len
);
2037 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2038 fromval
= value_cast (type
, fromval
);
2040 read_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
, len
);
2041 if (BITS_BIG_ENDIAN
)
2042 move_bits (buffer
, value_bitpos (toval
),
2043 value_contents (fromval
),
2044 TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
-
2047 move_bits (buffer
, value_bitpos (toval
), value_contents (fromval
),
2049 write_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
,
2052 val
= value_copy (toval
);
2053 memcpy (value_contents_raw (val
), value_contents (fromval
),
2054 TYPE_LENGTH (type
));
2055 deprecated_set_value_type (val
, type
);
2060 return value_assign (toval
, fromval
);
2064 /* The value of the element of array ARR at the ARITY indices given in IND.
2065 ARR may be either a simple array, GNAT array descriptor, or pointer
2069 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2073 struct type
*elt_type
;
2075 elt
= ada_coerce_to_simple_array (arr
);
2077 elt_type
= ada_check_typedef (value_type (elt
));
2078 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2079 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2080 return value_subscript_packed (elt
, arity
, ind
);
2082 for (k
= 0; k
< arity
; k
+= 1)
2084 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2085 error (_("too many subscripts (%d expected)"), k
);
2086 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2091 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2092 value of the element of *ARR at the ARITY indices given in
2093 IND. Does not read the entire array into memory. */
2096 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2101 for (k
= 0; k
< arity
; k
+= 1)
2106 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2107 error (_("too many subscripts (%d expected)"), k
);
2108 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2110 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2111 idx
= value_pos_atr (ind
[k
]);
2113 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2114 arr
= value_add (arr
, idx
);
2115 type
= TYPE_TARGET_TYPE (type
);
2118 return value_ind (arr
);
2121 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2122 actual type of ARRAY_PTR is ignored), returns a reference to
2123 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2124 bound of this array is LOW, as per Ada rules. */
2125 static struct value
*
2126 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2129 CORE_ADDR base
= value_as_address (array_ptr
)
2130 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2131 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2132 struct type
*index_type
=
2133 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2135 struct type
*slice_type
=
2136 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2137 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2141 static struct value
*
2142 ada_value_slice (struct value
*array
, int low
, int high
)
2144 struct type
*type
= value_type (array
);
2145 struct type
*index_type
=
2146 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2147 struct type
*slice_type
=
2148 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2149 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2152 /* If type is a record type in the form of a standard GNAT array
2153 descriptor, returns the number of dimensions for type. If arr is a
2154 simple array, returns the number of "array of"s that prefix its
2155 type designation. Otherwise, returns 0. */
2158 ada_array_arity (struct type
*type
)
2165 type
= desc_base_type (type
);
2168 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2169 return desc_arity (desc_bounds_type (type
));
2171 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2174 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2180 /* If TYPE is a record type in the form of a standard GNAT array
2181 descriptor or a simple array type, returns the element type for
2182 TYPE after indexing by NINDICES indices, or by all indices if
2183 NINDICES is -1. Otherwise, returns NULL. */
2186 ada_array_element_type (struct type
*type
, int nindices
)
2188 type
= desc_base_type (type
);
2190 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2193 struct type
*p_array_type
;
2195 p_array_type
= desc_data_type (type
);
2197 k
= ada_array_arity (type
);
2201 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2202 if (nindices
>= 0 && k
> nindices
)
2204 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2205 while (k
> 0 && p_array_type
!= NULL
)
2207 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2210 return p_array_type
;
2212 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2214 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2216 type
= TYPE_TARGET_TYPE (type
);
2225 /* The type of nth index in arrays of given type (n numbering from 1).
2226 Does not examine memory. */
2229 ada_index_type (struct type
*type
, int n
)
2231 struct type
*result_type
;
2233 type
= desc_base_type (type
);
2235 if (n
> ada_array_arity (type
))
2238 if (ada_is_simple_array_type (type
))
2242 for (i
= 1; i
< n
; i
+= 1)
2243 type
= TYPE_TARGET_TYPE (type
);
2244 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2245 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2246 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2247 perhaps stabsread.c would make more sense. */
2248 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2249 result_type
= builtin_type_int
;
2254 return desc_index_type (desc_bounds_type (type
), n
);
2257 /* Given that arr is an array type, returns the lower bound of the
2258 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2259 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2260 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2261 bounds type. It works for other arrays with bounds supplied by
2262 run-time quantities other than discriminants. */
2265 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2266 struct type
** typep
)
2269 struct type
*index_type_desc
;
2271 if (ada_is_packed_array_type (arr_type
))
2272 arr_type
= decode_packed_array_type (arr_type
);
2274 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2277 *typep
= builtin_type_int
;
2278 return (LONGEST
) - which
;
2281 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2282 type
= TYPE_TARGET_TYPE (arr_type
);
2286 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2287 if (index_type_desc
== NULL
)
2289 struct type
*range_type
;
2290 struct type
*index_type
;
2294 type
= TYPE_TARGET_TYPE (type
);
2298 range_type
= TYPE_INDEX_TYPE (type
);
2299 index_type
= TYPE_TARGET_TYPE (range_type
);
2300 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2301 index_type
= builtin_type_long
;
2303 *typep
= index_type
;
2305 (LONGEST
) (which
== 0
2306 ? TYPE_LOW_BOUND (range_type
)
2307 : TYPE_HIGH_BOUND (range_type
));
2311 struct type
*index_type
=
2312 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2313 NULL
, TYPE_OBJFILE (arr_type
));
2315 *typep
= TYPE_TARGET_TYPE (index_type
);
2317 (LONGEST
) (which
== 0
2318 ? TYPE_LOW_BOUND (index_type
)
2319 : TYPE_HIGH_BOUND (index_type
));
2323 /* Given that arr is an array value, returns the lower bound of the
2324 nth index (numbering from 1) if which is 0, and the upper bound if
2325 which is 1. This routine will also work for arrays with bounds
2326 supplied by run-time quantities other than discriminants. */
2329 ada_array_bound (struct value
*arr
, int n
, int which
)
2331 struct type
*arr_type
= value_type (arr
);
2333 if (ada_is_packed_array_type (arr_type
))
2334 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2335 else if (ada_is_simple_array_type (arr_type
))
2338 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2339 return value_from_longest (type
, v
);
2342 return desc_one_bound (desc_bounds (arr
), n
, which
);
2345 /* Given that arr is an array value, returns the length of the
2346 nth index. This routine will also work for arrays with bounds
2347 supplied by run-time quantities other than discriminants.
2348 Does not work for arrays indexed by enumeration types with representation
2349 clauses at the moment. */
2352 ada_array_length (struct value
*arr
, int n
)
2354 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2356 if (ada_is_packed_array_type (arr_type
))
2357 return ada_array_length (decode_packed_array (arr
), n
);
2359 if (ada_is_simple_array_type (arr_type
))
2363 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2364 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2365 return value_from_longest (type
, v
);
2369 value_from_longest (builtin_type_int
,
2370 value_as_long (desc_one_bound (desc_bounds (arr
),
2372 - value_as_long (desc_one_bound (desc_bounds (arr
),
2376 /* An empty array whose type is that of ARR_TYPE (an array type),
2377 with bounds LOW to LOW-1. */
2379 static struct value
*
2380 empty_array (struct type
*arr_type
, int low
)
2382 struct type
*index_type
=
2383 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2385 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2386 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2390 /* Name resolution */
2392 /* The "decoded" name for the user-definable Ada operator corresponding
2396 ada_decoded_op_name (enum exp_opcode op
)
2400 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2402 if (ada_opname_table
[i
].op
== op
)
2403 return ada_opname_table
[i
].decoded
;
2405 error (_("Could not find operator name for opcode"));
2409 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2410 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2411 undefined namespace) and converts operators that are
2412 user-defined into appropriate function calls. If CONTEXT_TYPE is
2413 non-null, it provides a preferred result type [at the moment, only
2414 type void has any effect---causing procedures to be preferred over
2415 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2416 return type is preferred. May change (expand) *EXP. */
2419 resolve (struct expression
**expp
, int void_context_p
)
2423 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2426 /* Resolve the operator of the subexpression beginning at
2427 position *POS of *EXPP. "Resolving" consists of replacing
2428 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2429 with their resolutions, replacing built-in operators with
2430 function calls to user-defined operators, where appropriate, and,
2431 when DEPROCEDURE_P is non-zero, converting function-valued variables
2432 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2433 are as in ada_resolve, above. */
2435 static struct value
*
2436 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2437 struct type
*context_type
)
2441 struct expression
*exp
; /* Convenience: == *expp. */
2442 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2443 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2444 int nargs
; /* Number of operands. */
2450 /* Pass one: resolve operands, saving their types and updating *pos. */
2454 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2455 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2460 resolve_subexp (expp
, pos
, 0, NULL
);
2462 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2467 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2472 resolve_subexp (expp
, pos
, 0, NULL
);
2475 case OP_ATR_MODULUS
:
2505 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2507 resolve_subexp (expp
, pos
, 1, NULL
);
2509 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2527 case BINOP_LOGICAL_AND
:
2528 case BINOP_LOGICAL_OR
:
2529 case BINOP_BITWISE_AND
:
2530 case BINOP_BITWISE_IOR
:
2531 case BINOP_BITWISE_XOR
:
2534 case BINOP_NOTEQUAL
:
2541 case BINOP_SUBSCRIPT
:
2549 case UNOP_LOGICAL_NOT
:
2566 case OP_INTERNALVAR
:
2575 case STRUCTOP_STRUCT
:
2576 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2582 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2587 case TERNOP_IN_RANGE
:
2592 case BINOP_IN_BOUNDS
:
2598 error (_("Unexpected operator during name resolution"));
2601 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2602 for (i
= 0; i
< nargs
; i
+= 1)
2603 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2607 /* Pass two: perform any resolution on principal operator. */
2614 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2616 struct ada_symbol_info
*candidates
;
2620 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2621 (exp
->elts
[pc
+ 2].symbol
),
2622 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2625 if (n_candidates
> 1)
2627 /* Types tend to get re-introduced locally, so if there
2628 are any local symbols that are not types, first filter
2631 for (j
= 0; j
< n_candidates
; j
+= 1)
2632 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2638 case LOC_REGPARM_ADDR
:
2642 case LOC_BASEREG_ARG
:
2644 case LOC_COMPUTED_ARG
:
2650 if (j
< n_candidates
)
2653 while (j
< n_candidates
)
2655 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2657 candidates
[j
] = candidates
[n_candidates
- 1];
2666 if (n_candidates
== 0)
2667 error (_("No definition found for %s"),
2668 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2669 else if (n_candidates
== 1)
2671 else if (deprocedure_p
2672 && !is_nonfunction (candidates
, n_candidates
))
2674 i
= ada_resolve_function
2675 (candidates
, n_candidates
, NULL
, 0,
2676 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2679 error (_("Could not find a match for %s"),
2680 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2684 printf_filtered (_("Multiple matches for %s\n"),
2685 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2686 user_select_syms (candidates
, n_candidates
, 1);
2690 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2691 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2692 if (innermost_block
== NULL
2693 || contained_in (candidates
[i
].block
, innermost_block
))
2694 innermost_block
= candidates
[i
].block
;
2698 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2701 replace_operator_with_call (expp
, pc
, 0, 0,
2702 exp
->elts
[pc
+ 2].symbol
,
2703 exp
->elts
[pc
+ 1].block
);
2710 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2711 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2713 struct ada_symbol_info
*candidates
;
2717 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2718 (exp
->elts
[pc
+ 5].symbol
),
2719 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2721 if (n_candidates
== 1)
2725 i
= ada_resolve_function
2726 (candidates
, n_candidates
,
2728 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2731 error (_("Could not find a match for %s"),
2732 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2735 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2736 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2737 if (innermost_block
== NULL
2738 || contained_in (candidates
[i
].block
, innermost_block
))
2739 innermost_block
= candidates
[i
].block
;
2750 case BINOP_BITWISE_AND
:
2751 case BINOP_BITWISE_IOR
:
2752 case BINOP_BITWISE_XOR
:
2754 case BINOP_NOTEQUAL
:
2762 case UNOP_LOGICAL_NOT
:
2764 if (possible_user_operator_p (op
, argvec
))
2766 struct ada_symbol_info
*candidates
;
2770 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2771 (struct block
*) NULL
, VAR_DOMAIN
,
2773 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2774 ada_decoded_op_name (op
), NULL
);
2778 replace_operator_with_call (expp
, pc
, nargs
, 1,
2779 candidates
[i
].sym
, candidates
[i
].block
);
2789 return evaluate_subexp_type (exp
, pos
);
2792 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2793 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2794 a non-pointer. A type of 'void' (which is never a valid expression type)
2795 by convention matches anything. */
2796 /* The term "match" here is rather loose. The match is heuristic and
2797 liberal. FIXME: TOO liberal, in fact. */
2800 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2802 ftype
= ada_check_typedef (ftype
);
2803 atype
= ada_check_typedef (atype
);
2805 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2806 ftype
= TYPE_TARGET_TYPE (ftype
);
2807 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2808 atype
= TYPE_TARGET_TYPE (atype
);
2810 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2811 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2814 switch (TYPE_CODE (ftype
))
2819 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2820 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2821 TYPE_TARGET_TYPE (atype
), 0);
2824 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2826 case TYPE_CODE_ENUM
:
2827 case TYPE_CODE_RANGE
:
2828 switch (TYPE_CODE (atype
))
2831 case TYPE_CODE_ENUM
:
2832 case TYPE_CODE_RANGE
:
2838 case TYPE_CODE_ARRAY
:
2839 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2840 || ada_is_array_descriptor_type (atype
));
2842 case TYPE_CODE_STRUCT
:
2843 if (ada_is_array_descriptor_type (ftype
))
2844 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2845 || ada_is_array_descriptor_type (atype
));
2847 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2848 && !ada_is_array_descriptor_type (atype
));
2850 case TYPE_CODE_UNION
:
2852 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2856 /* Return non-zero if the formals of FUNC "sufficiently match" the
2857 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2858 may also be an enumeral, in which case it is treated as a 0-
2859 argument function. */
2862 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2865 struct type
*func_type
= SYMBOL_TYPE (func
);
2867 if (SYMBOL_CLASS (func
) == LOC_CONST
2868 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2869 return (n_actuals
== 0);
2870 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2873 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2876 for (i
= 0; i
< n_actuals
; i
+= 1)
2878 if (actuals
[i
] == NULL
)
2882 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2883 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
2885 if (!ada_type_match (ftype
, atype
, 1))
2892 /* False iff function type FUNC_TYPE definitely does not produce a value
2893 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2894 FUNC_TYPE is not a valid function type with a non-null return type
2895 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2898 return_match (struct type
*func_type
, struct type
*context_type
)
2900 struct type
*return_type
;
2902 if (func_type
== NULL
)
2905 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2906 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2908 return_type
= base_type (func_type
);
2909 if (return_type
== NULL
)
2912 context_type
= base_type (context_type
);
2914 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2915 return context_type
== NULL
|| return_type
== context_type
;
2916 else if (context_type
== NULL
)
2917 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2919 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2923 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
2924 function (if any) that matches the types of the NARGS arguments in
2925 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2926 that returns that type, then eliminate matches that don't. If
2927 CONTEXT_TYPE is void and there is at least one match that does not
2928 return void, eliminate all matches that do.
2930 Asks the user if there is more than one match remaining. Returns -1
2931 if there is no such symbol or none is selected. NAME is used
2932 solely for messages. May re-arrange and modify SYMS in
2933 the process; the index returned is for the modified vector. */
2936 ada_resolve_function (struct ada_symbol_info syms
[],
2937 int nsyms
, struct value
**args
, int nargs
,
2938 const char *name
, struct type
*context_type
)
2941 int m
; /* Number of hits */
2942 struct type
*fallback
;
2943 struct type
*return_type
;
2945 return_type
= context_type
;
2946 if (context_type
== NULL
)
2947 fallback
= builtin_type_void
;
2954 for (k
= 0; k
< nsyms
; k
+= 1)
2956 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
2958 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
2959 && return_match (type
, return_type
))
2965 if (m
> 0 || return_type
== fallback
)
2968 return_type
= fallback
;
2975 printf_filtered (_("Multiple matches for %s\n"), name
);
2976 user_select_syms (syms
, m
, 1);
2982 /* Returns true (non-zero) iff decoded name N0 should appear before N1
2983 in a listing of choices during disambiguation (see sort_choices, below).
2984 The idea is that overloadings of a subprogram name from the
2985 same package should sort in their source order. We settle for ordering
2986 such symbols by their trailing number (__N or $N). */
2989 encoded_ordered_before (char *N0
, char *N1
)
2993 else if (N0
== NULL
)
2998 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3000 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3002 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3003 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3007 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3010 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3012 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3013 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3015 return (strcmp (N0
, N1
) < 0);
3019 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3023 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3026 for (i
= 1; i
< nsyms
; i
+= 1)
3028 struct ada_symbol_info sym
= syms
[i
];
3031 for (j
= i
- 1; j
>= 0; j
-= 1)
3033 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3034 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3036 syms
[j
+ 1] = syms
[j
];
3042 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3043 by asking the user (if necessary), returning the number selected,
3044 and setting the first elements of SYMS items. Error if no symbols
3047 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3048 to be re-integrated one of these days. */
3051 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3054 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3056 int first_choice
= (max_results
== 1) ? 1 : 2;
3058 if (max_results
< 1)
3059 error (_("Request to select 0 symbols!"));
3063 printf_unfiltered (_("[0] cancel\n"));
3064 if (max_results
> 1)
3065 printf_unfiltered (_("[1] all\n"));
3067 sort_choices (syms
, nsyms
);
3069 for (i
= 0; i
< nsyms
; i
+= 1)
3071 if (syms
[i
].sym
== NULL
)
3074 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3076 struct symtab_and_line sal
=
3077 find_function_start_sal (syms
[i
].sym
, 1);
3078 if (sal
.symtab
== NULL
)
3079 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3081 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3084 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3085 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3086 sal
.symtab
->filename
, sal
.line
);
3092 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3093 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3094 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3095 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3097 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3098 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3100 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3101 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3102 else if (is_enumeral
3103 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3105 printf_unfiltered (("[%d] "), i
+ first_choice
);
3106 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3108 printf_unfiltered (_("'(%s) (enumeral)\n"),
3109 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3111 else if (symtab
!= NULL
)
3112 printf_unfiltered (is_enumeral
3113 ? _("[%d] %s in %s (enumeral)\n")
3114 : _("[%d] %s at %s:?\n"),
3116 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3119 printf_unfiltered (is_enumeral
3120 ? _("[%d] %s (enumeral)\n")
3121 : _("[%d] %s at ?\n"),
3123 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3127 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3130 for (i
= 0; i
< n_chosen
; i
+= 1)
3131 syms
[i
] = syms
[chosen
[i
]];
3136 /* Read and validate a set of numeric choices from the user in the
3137 range 0 .. N_CHOICES-1. Place the results in increasing
3138 order in CHOICES[0 .. N-1], and return N.
3140 The user types choices as a sequence of numbers on one line
3141 separated by blanks, encoding them as follows:
3143 + A choice of 0 means to cancel the selection, throwing an error.
3144 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3145 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3147 The user is not allowed to choose more than MAX_RESULTS values.
3149 ANNOTATION_SUFFIX, if present, is used to annotate the input
3150 prompts (for use with the -f switch). */
3153 get_selections (int *choices
, int n_choices
, int max_results
,
3154 int is_all_choice
, char *annotation_suffix
)
3159 int first_choice
= is_all_choice
? 2 : 1;
3161 prompt
= getenv ("PS2");
3165 printf_unfiltered (("%s "), prompt
);
3166 gdb_flush (gdb_stdout
);
3168 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3171 error_no_arg (_("one or more choice numbers"));
3175 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3176 order, as given in args. Choices are validated. */
3182 while (isspace (*args
))
3184 if (*args
== '\0' && n_chosen
== 0)
3185 error_no_arg (_("one or more choice numbers"));
3186 else if (*args
== '\0')
3189 choice
= strtol (args
, &args2
, 10);
3190 if (args
== args2
|| choice
< 0
3191 || choice
> n_choices
+ first_choice
- 1)
3192 error (_("Argument must be choice number"));
3196 error (_("cancelled"));
3198 if (choice
< first_choice
)
3200 n_chosen
= n_choices
;
3201 for (j
= 0; j
< n_choices
; j
+= 1)
3205 choice
-= first_choice
;
3207 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3211 if (j
< 0 || choice
!= choices
[j
])
3214 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3215 choices
[k
+ 1] = choices
[k
];
3216 choices
[j
+ 1] = choice
;
3221 if (n_chosen
> max_results
)
3222 error (_("Select no more than %d of the above"), max_results
);
3227 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3228 on the function identified by SYM and BLOCK, and taking NARGS
3229 arguments. Update *EXPP as needed to hold more space. */
3232 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3233 int oplen
, struct symbol
*sym
,
3234 struct block
*block
)
3236 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3237 symbol, -oplen for operator being replaced). */
3238 struct expression
*newexp
= (struct expression
*)
3239 xmalloc (sizeof (struct expression
)
3240 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3241 struct expression
*exp
= *expp
;
3243 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3244 newexp
->language_defn
= exp
->language_defn
;
3245 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3246 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3247 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3249 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3250 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3252 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3253 newexp
->elts
[pc
+ 4].block
= block
;
3254 newexp
->elts
[pc
+ 5].symbol
= sym
;
3260 /* Type-class predicates */
3262 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3266 numeric_type_p (struct type
*type
)
3272 switch (TYPE_CODE (type
))
3277 case TYPE_CODE_RANGE
:
3278 return (type
== TYPE_TARGET_TYPE (type
)
3279 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3286 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3289 integer_type_p (struct type
*type
)
3295 switch (TYPE_CODE (type
))
3299 case TYPE_CODE_RANGE
:
3300 return (type
== TYPE_TARGET_TYPE (type
)
3301 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3308 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3311 scalar_type_p (struct type
*type
)
3317 switch (TYPE_CODE (type
))
3320 case TYPE_CODE_RANGE
:
3321 case TYPE_CODE_ENUM
:
3330 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3333 discrete_type_p (struct type
*type
)
3339 switch (TYPE_CODE (type
))
3342 case TYPE_CODE_RANGE
:
3343 case TYPE_CODE_ENUM
:
3351 /* Returns non-zero if OP with operands in the vector ARGS could be
3352 a user-defined function. Errs on the side of pre-defined operators
3353 (i.e., result 0). */
3356 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3358 struct type
*type0
=
3359 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3360 struct type
*type1
=
3361 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3375 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3379 case BINOP_BITWISE_AND
:
3380 case BINOP_BITWISE_IOR
:
3381 case BINOP_BITWISE_XOR
:
3382 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3385 case BINOP_NOTEQUAL
:
3390 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3394 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3395 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3396 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3397 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3398 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3399 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
))
3400 != TYPE_CODE_ARRAY
))));
3403 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3407 case UNOP_LOGICAL_NOT
:
3409 return (!numeric_type_p (type0
));
3416 /* NOTE: In the following, we assume that a renaming type's name may
3417 have an ___XD suffix. It would be nice if this went away at some
3420 /* If TYPE encodes a renaming, returns the renaming suffix, which
3421 is XR for an object renaming, XRP for a procedure renaming, XRE for
3422 an exception renaming, and XRS for a subprogram renaming. Returns
3423 NULL if NAME encodes none of these. */
3426 ada_renaming_type (struct type
*type
)
3428 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3430 const char *name
= type_name_no_tag (type
);
3431 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3433 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3442 /* Return non-zero iff SYM encodes an object renaming. */
3445 ada_is_object_renaming (struct symbol
*sym
)
3447 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3448 return renaming_type
!= NULL
3449 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3452 /* Assuming that SYM encodes a non-object renaming, returns the original
3453 name of the renamed entity. The name is good until the end of
3457 ada_simple_renamed_entity (struct symbol
*sym
)
3460 const char *raw_name
;
3464 type
= SYMBOL_TYPE (sym
);
3465 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3466 error (_("Improperly encoded renaming."));
3468 raw_name
= TYPE_FIELD_NAME (type
, 0);
3469 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3471 error (_("Improperly encoded renaming."));
3473 result
= xmalloc (len
+ 1);
3474 strncpy (result
, raw_name
, len
);
3475 result
[len
] = '\000';
3480 /* Evaluation: Function Calls */
3482 /* Return an lvalue containing the value VAL. This is the identity on
3483 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3484 on the stack, using and updating *SP as the stack pointer, and
3485 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3487 static struct value
*
3488 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3490 if (! VALUE_LVAL (val
))
3492 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3494 /* The following is taken from the structure-return code in
3495 call_function_by_hand. FIXME: Therefore, some refactoring seems
3497 if (INNER_THAN (1, 2))
3499 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3500 reserving sufficient space. */
3502 if (gdbarch_frame_align_p (current_gdbarch
))
3503 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3504 VALUE_ADDRESS (val
) = *sp
;
3508 /* Stack grows upward. Align the frame, allocate space, and
3509 then again, re-align the frame. */
3510 if (gdbarch_frame_align_p (current_gdbarch
))
3511 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3512 VALUE_ADDRESS (val
) = *sp
;
3514 if (gdbarch_frame_align_p (current_gdbarch
))
3515 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3518 write_memory (VALUE_ADDRESS (val
), value_contents_raw (val
), len
);
3524 /* Return the value ACTUAL, converted to be an appropriate value for a
3525 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3526 allocating any necessary descriptors (fat pointers), or copies of
3527 values not residing in memory, updating it as needed. */
3529 static struct value
*
3530 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3533 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3534 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3535 struct type
*formal_target
=
3536 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3537 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3538 struct type
*actual_target
=
3539 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3540 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3542 if (ada_is_array_descriptor_type (formal_target
)
3543 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3544 return make_array_descriptor (formal_type
, actual
, sp
);
3545 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3547 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3548 && ada_is_array_descriptor_type (actual_target
))
3549 return desc_data (actual
);
3550 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3552 if (VALUE_LVAL (actual
) != lval_memory
)
3555 actual_type
= ada_check_typedef (value_type (actual
));
3556 val
= allocate_value (actual_type
);
3557 memcpy ((char *) value_contents_raw (val
),
3558 (char *) value_contents (actual
),
3559 TYPE_LENGTH (actual_type
));
3560 actual
= ensure_lval (val
, sp
);
3562 return value_addr (actual
);
3565 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3566 return ada_value_ind (actual
);
3572 /* Push a descriptor of type TYPE for array value ARR on the stack at
3573 *SP, updating *SP to reflect the new descriptor. Return either
3574 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3575 to-descriptor type rather than a descriptor type), a struct value *
3576 representing a pointer to this descriptor. */
3578 static struct value
*
3579 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3581 struct type
*bounds_type
= desc_bounds_type (type
);
3582 struct type
*desc_type
= desc_base_type (type
);
3583 struct value
*descriptor
= allocate_value (desc_type
);
3584 struct value
*bounds
= allocate_value (bounds_type
);
3587 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3589 modify_general_field (value_contents_writeable (bounds
),
3590 value_as_long (ada_array_bound (arr
, i
, 0)),
3591 desc_bound_bitpos (bounds_type
, i
, 0),
3592 desc_bound_bitsize (bounds_type
, i
, 0));
3593 modify_general_field (value_contents_writeable (bounds
),
3594 value_as_long (ada_array_bound (arr
, i
, 1)),
3595 desc_bound_bitpos (bounds_type
, i
, 1),
3596 desc_bound_bitsize (bounds_type
, i
, 1));
3599 bounds
= ensure_lval (bounds
, sp
);
3601 modify_general_field (value_contents_writeable (descriptor
),
3602 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3603 fat_pntr_data_bitpos (desc_type
),
3604 fat_pntr_data_bitsize (desc_type
));
3606 modify_general_field (value_contents_writeable (descriptor
),
3607 VALUE_ADDRESS (bounds
),
3608 fat_pntr_bounds_bitpos (desc_type
),
3609 fat_pntr_bounds_bitsize (desc_type
));
3611 descriptor
= ensure_lval (descriptor
, sp
);
3613 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3614 return value_addr (descriptor
);
3620 /* Assuming a dummy frame has been established on the target, perform any
3621 conversions needed for calling function FUNC on the NARGS actual
3622 parameters in ARGS, other than standard C conversions. Does
3623 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3624 does not match the number of arguments expected. Use *SP as a
3625 stack pointer for additional data that must be pushed, updating its
3629 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3634 if (TYPE_NFIELDS (value_type (func
)) == 0
3635 || nargs
!= TYPE_NFIELDS (value_type (func
)))
3638 for (i
= 0; i
< nargs
; i
+= 1)
3640 convert_actual (args
[i
], TYPE_FIELD_TYPE (value_type (func
), i
), sp
);
3643 /* Dummy definitions for an experimental caching module that is not
3644 * used in the public sources. */
3647 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3648 struct symbol
**sym
, struct block
**block
,
3649 struct symtab
**symtab
)
3655 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3656 struct block
*block
, struct symtab
*symtab
)
3662 /* Return the result of a standard (literal, C-like) lookup of NAME in
3663 given DOMAIN, visible from lexical block BLOCK. */
3665 static struct symbol
*
3666 standard_lookup (const char *name
, const struct block
*block
,
3670 struct symtab
*symtab
;
3672 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3675 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3676 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3681 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3682 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3683 since they contend in overloading in the same way. */
3685 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3689 for (i
= 0; i
< n
; i
+= 1)
3690 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3691 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3692 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3698 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3699 struct types. Otherwise, they may not. */
3702 equiv_types (struct type
*type0
, struct type
*type1
)
3706 if (type0
== NULL
|| type1
== NULL
3707 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3709 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3710 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3711 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3712 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3718 /* True iff SYM0 represents the same entity as SYM1, or one that is
3719 no more defined than that of SYM1. */
3722 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3726 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3727 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3730 switch (SYMBOL_CLASS (sym0
))
3736 struct type
*type0
= SYMBOL_TYPE (sym0
);
3737 struct type
*type1
= SYMBOL_TYPE (sym1
);
3738 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3739 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3740 int len0
= strlen (name0
);
3742 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3743 && (equiv_types (type0
, type1
)
3744 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3745 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3748 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3749 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3755 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3756 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3759 add_defn_to_vec (struct obstack
*obstackp
,
3761 struct block
*block
, struct symtab
*symtab
)
3765 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3767 if (SYMBOL_TYPE (sym
) != NULL
)
3768 SYMBOL_TYPE (sym
) = ada_check_typedef (SYMBOL_TYPE (sym
));
3769 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3771 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3773 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3775 prevDefns
[i
].sym
= sym
;
3776 prevDefns
[i
].block
= block
;
3777 prevDefns
[i
].symtab
= symtab
;
3783 struct ada_symbol_info info
;
3787 info
.symtab
= symtab
;
3788 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3792 /* Number of ada_symbol_info structures currently collected in
3793 current vector in *OBSTACKP. */
3796 num_defns_collected (struct obstack
*obstackp
)
3798 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3801 /* Vector of ada_symbol_info structures currently collected in current
3802 vector in *OBSTACKP. If FINISH, close off the vector and return
3803 its final address. */
3805 static struct ada_symbol_info
*
3806 defns_collected (struct obstack
*obstackp
, int finish
)
3809 return obstack_finish (obstackp
);
3811 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3814 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3815 Check the global symbols if GLOBAL, the static symbols if not.
3816 Do wild-card match if WILD. */
3818 static struct partial_symbol
*
3819 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3820 int global
, domain_enum
namespace, int wild
)
3822 struct partial_symbol
**start
;
3823 int name_len
= strlen (name
);
3824 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3833 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3834 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3838 for (i
= 0; i
< length
; i
+= 1)
3840 struct partial_symbol
*psym
= start
[i
];
3842 if (SYMBOL_DOMAIN (psym
) == namespace
3843 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3857 int M
= (U
+ i
) >> 1;
3858 struct partial_symbol
*psym
= start
[M
];
3859 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3861 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3863 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
3874 struct partial_symbol
*psym
= start
[i
];
3876 if (SYMBOL_DOMAIN (psym
) == namespace)
3878 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
3886 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3900 int M
= (U
+ i
) >> 1;
3901 struct partial_symbol
*psym
= start
[M
];
3902 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
3904 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
3906 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
3917 struct partial_symbol
*psym
= start
[i
];
3919 if (SYMBOL_DOMAIN (psym
) == namespace)
3923 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
3926 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
3928 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
3938 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3948 /* Find a symbol table containing symbol SYM or NULL if none. */
3950 static struct symtab
*
3951 symtab_for_sym (struct symbol
*sym
)
3954 struct objfile
*objfile
;
3956 struct symbol
*tmp_sym
;
3957 struct dict_iterator iter
;
3960 ALL_SYMTABS (objfile
, s
)
3962 switch (SYMBOL_CLASS (sym
))
3970 case LOC_CONST_BYTES
:
3971 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3972 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3974 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3975 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3981 switch (SYMBOL_CLASS (sym
))
3987 case LOC_REGPARM_ADDR
:
3992 case LOC_BASEREG_ARG
:
3994 case LOC_COMPUTED_ARG
:
3995 for (j
= FIRST_LOCAL_BLOCK
;
3996 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3998 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3999 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4010 /* Return a minimal symbol matching NAME according to Ada decoding
4011 rules. Returns NULL if there is no such minimal symbol. Names
4012 prefixed with "standard__" are handled specially: "standard__" is
4013 first stripped off, and only static and global symbols are searched. */
4015 struct minimal_symbol
*
4016 ada_lookup_simple_minsym (const char *name
)
4018 struct objfile
*objfile
;
4019 struct minimal_symbol
*msymbol
;
4022 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4024 name
+= sizeof ("standard__") - 1;
4028 wild_match
= (strstr (name
, "__") == NULL
);
4030 ALL_MSYMBOLS (objfile
, msymbol
)
4032 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4033 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4040 /* For all subprograms that statically enclose the subprogram of the
4041 selected frame, add symbols matching identifier NAME in DOMAIN
4042 and their blocks to the list of data in OBSTACKP, as for
4043 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4047 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4048 const char *name
, domain_enum
namespace,
4053 /* FIXME: The next two routines belong in symtab.c */
4056 restore_language (void *lang
)
4058 set_language ((enum language
) lang
);
4061 /* As for lookup_symbol, but performed as if the current language
4065 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4066 domain_enum domain
, enum language lang
,
4067 int *is_a_field_of_this
, struct symtab
**symtab
)
4069 struct cleanup
*old_chain
4070 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4071 struct symbol
*result
;
4072 set_language (lang
);
4073 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4074 do_cleanups (old_chain
);
4078 /* True if TYPE is definitely an artificial type supplied to a symbol
4079 for which no debugging information was given in the symbol file. */
4082 is_nondebugging_type (struct type
*type
)
4084 char *name
= ada_type_name (type
);
4085 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4088 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4089 duplicate other symbols in the list (The only case I know of where
4090 this happens is when object files containing stabs-in-ecoff are
4091 linked with files containing ordinary ecoff debugging symbols (or no
4092 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4093 Returns the number of items in the modified list. */
4096 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4103 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4104 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4105 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4107 for (j
= 0; j
< nsyms
; j
+= 1)
4110 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4111 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4112 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4113 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4114 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4115 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4118 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4119 syms
[k
- 1] = syms
[k
];
4132 /* Given a type that corresponds to a renaming entity, use the type name
4133 to extract the scope (package name or function name, fully qualified,
4134 and following the GNAT encoding convention) where this renaming has been
4135 defined. The string returned needs to be deallocated after use. */
4138 xget_renaming_scope (struct type
*renaming_type
)
4140 /* The renaming types adhere to the following convention:
4141 <scope>__<rename>___<XR extension>.
4142 So, to extract the scope, we search for the "___XR" extension,
4143 and then backtrack until we find the first "__". */
4145 const char *name
= type_name_no_tag (renaming_type
);
4146 char *suffix
= strstr (name
, "___XR");
4151 /* Now, backtrack a bit until we find the first "__". Start looking
4152 at suffix - 3, as the <rename> part is at least one character long. */
4154 for (last
= suffix
- 3; last
> name
; last
--)
4155 if (last
[0] == '_' && last
[1] == '_')
4158 /* Make a copy of scope and return it. */
4160 scope_len
= last
- name
;
4161 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4163 strncpy (scope
, name
, scope_len
);
4164 scope
[scope_len
] = '\0';
4169 /* Return nonzero if NAME corresponds to a package name. */
4172 is_package_name (const char *name
)
4174 /* Here, We take advantage of the fact that no symbols are generated
4175 for packages, while symbols are generated for each function.
4176 So the condition for NAME represent a package becomes equivalent
4177 to NAME not existing in our list of symbols. There is only one
4178 small complication with library-level functions (see below). */
4182 /* If it is a function that has not been defined at library level,
4183 then we should be able to look it up in the symbols. */
4184 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4187 /* Library-level function names start with "_ada_". See if function
4188 "_ada_" followed by NAME can be found. */
4190 /* Do a quick check that NAME does not contain "__", since library-level
4191 functions names can not contain "__" in them. */
4192 if (strstr (name
, "__") != NULL
)
4195 fun_name
= xstrprintf ("_ada_%s", name
);
4197 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4200 /* Return nonzero if SYM corresponds to a renaming entity that is
4201 visible from FUNCTION_NAME. */
4204 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4206 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4208 make_cleanup (xfree
, scope
);
4210 /* If the rename has been defined in a package, then it is visible. */
4211 if (is_package_name (scope
))
4214 /* Check that the rename is in the current function scope by checking
4215 that its name starts with SCOPE. */
4217 /* If the function name starts with "_ada_", it means that it is
4218 a library-level function. Strip this prefix before doing the
4219 comparison, as the encoding for the renaming does not contain
4221 if (strncmp (function_name
, "_ada_", 5) == 0)
4224 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4227 /* Iterates over the SYMS list and remove any entry that corresponds to
4228 a renaming entity that is not visible from the function associated
4232 GNAT emits a type following a specified encoding for each renaming
4233 entity. Unfortunately, STABS currently does not support the definition
4234 of types that are local to a given lexical block, so all renamings types
4235 are emitted at library level. As a consequence, if an application
4236 contains two renaming entities using the same name, and a user tries to
4237 print the value of one of these entities, the result of the ada symbol
4238 lookup will also contain the wrong renaming type.
4240 This function partially covers for this limitation by attempting to
4241 remove from the SYMS list renaming symbols that should be visible
4242 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4243 method with the current information available. The implementation
4244 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4246 - When the user tries to print a rename in a function while there
4247 is another rename entity defined in a package: Normally, the
4248 rename in the function has precedence over the rename in the
4249 package, so the latter should be removed from the list. This is
4250 currently not the case.
4252 - This function will incorrectly remove valid renames if
4253 the CURRENT_BLOCK corresponds to a function which symbol name
4254 has been changed by an "Export" pragma. As a consequence,
4255 the user will be unable to print such rename entities. */
4258 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4259 int nsyms
, struct block
*current_block
)
4261 struct symbol
*current_function
;
4262 char *current_function_name
;
4265 /* Extract the function name associated to CURRENT_BLOCK.
4266 Abort if unable to do so. */
4268 if (current_block
== NULL
)
4271 current_function
= block_function (current_block
);
4272 if (current_function
== NULL
)
4275 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4276 if (current_function_name
== NULL
)
4279 /* Check each of the symbols, and remove it from the list if it is
4280 a type corresponding to a renaming that is out of the scope of
4281 the current block. */
4286 if (ada_is_object_renaming (syms
[i
].sym
)
4287 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4290 for (j
= i
+ 1; j
< nsyms
; j
++)
4291 syms
[j
- 1] = syms
[j
];
4301 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4302 scope and in global scopes, returning the number of matches. Sets
4303 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4304 indicating the symbols found and the blocks and symbol tables (if
4305 any) in which they were found. This vector are transient---good only to
4306 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4307 symbol match within the nest of blocks whose innermost member is BLOCK0,
4308 is the one match returned (no other matches in that or
4309 enclosing blocks is returned). If there are any matches in or
4310 surrounding BLOCK0, then these alone are returned. Otherwise, the
4311 search extends to global and file-scope (static) symbol tables.
4312 Names prefixed with "standard__" are handled specially: "standard__"
4313 is first stripped off, and only static and global symbols are searched. */
4316 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4317 domain_enum
namespace,
4318 struct ada_symbol_info
**results
)
4322 struct partial_symtab
*ps
;
4323 struct blockvector
*bv
;
4324 struct objfile
*objfile
;
4325 struct block
*block
;
4327 struct minimal_symbol
*msymbol
;
4333 obstack_free (&symbol_list_obstack
, NULL
);
4334 obstack_init (&symbol_list_obstack
);
4338 /* Search specified block and its superiors. */
4340 wild_match
= (strstr (name0
, "__") == NULL
);
4342 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4343 needed, but adding const will
4344 have a cascade effect. */
4345 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4349 name
= name0
+ sizeof ("standard__") - 1;
4353 while (block
!= NULL
)
4356 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4357 namespace, NULL
, NULL
, wild_match
);
4359 /* If we found a non-function match, assume that's the one. */
4360 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4361 num_defns_collected (&symbol_list_obstack
)))
4364 block
= BLOCK_SUPERBLOCK (block
);
4367 /* If no luck so far, try to find NAME as a local symbol in some lexically
4368 enclosing subprogram. */
4369 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4370 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4371 name
, namespace, wild_match
);
4373 /* If we found ANY matches among non-global symbols, we're done. */
4375 if (num_defns_collected (&symbol_list_obstack
) > 0)
4379 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4382 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4386 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4387 tables, and psymtab's. */
4389 ALL_SYMTABS (objfile
, s
)
4394 bv
= BLOCKVECTOR (s
);
4395 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4396 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4397 objfile
, s
, wild_match
);
4400 if (namespace == VAR_DOMAIN
)
4402 ALL_MSYMBOLS (objfile
, msymbol
)
4404 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4406 switch (MSYMBOL_TYPE (msymbol
))
4408 case mst_solib_trampoline
:
4411 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4414 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4416 bv
= BLOCKVECTOR (s
);
4417 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4418 ada_add_block_symbols (&symbol_list_obstack
, block
,
4419 SYMBOL_LINKAGE_NAME (msymbol
),
4420 namespace, objfile
, s
, wild_match
);
4422 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4424 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4425 ada_add_block_symbols (&symbol_list_obstack
, block
,
4426 SYMBOL_LINKAGE_NAME (msymbol
),
4427 namespace, objfile
, s
,
4436 ALL_PSYMTABS (objfile
, ps
)
4440 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4442 s
= PSYMTAB_TO_SYMTAB (ps
);
4445 bv
= BLOCKVECTOR (s
);
4446 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4447 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4448 namespace, objfile
, s
, wild_match
);
4452 /* Now add symbols from all per-file blocks if we've gotten no hits
4453 (Not strictly correct, but perhaps better than an error).
4454 Do the symtabs first, then check the psymtabs. */
4456 if (num_defns_collected (&symbol_list_obstack
) == 0)
4459 ALL_SYMTABS (objfile
, s
)
4464 bv
= BLOCKVECTOR (s
);
4465 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4466 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4467 objfile
, s
, wild_match
);
4470 ALL_PSYMTABS (objfile
, ps
)
4474 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4476 s
= PSYMTAB_TO_SYMTAB (ps
);
4477 bv
= BLOCKVECTOR (s
);
4480 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4481 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4482 namespace, objfile
, s
, wild_match
);
4488 ndefns
= num_defns_collected (&symbol_list_obstack
);
4489 *results
= defns_collected (&symbol_list_obstack
, 1);
4491 ndefns
= remove_extra_symbols (*results
, ndefns
);
4494 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4496 if (ndefns
== 1 && cacheIfUnique
)
4497 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4498 (*results
)[0].symtab
);
4500 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4501 (struct block
*) block0
);
4506 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4507 scope and in global scopes, or NULL if none. NAME is folded and
4508 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4509 choosing the first symbol if there are multiple choices.
4510 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4511 table in which the symbol was found (in both cases, these
4512 assignments occur only if the pointers are non-null). */
4515 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4516 domain_enum
namespace, int *is_a_field_of_this
,
4517 struct symtab
**symtab
)
4519 struct ada_symbol_info
*candidates
;
4522 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4523 block0
, namespace, &candidates
);
4525 if (n_candidates
== 0)
4528 if (is_a_field_of_this
!= NULL
)
4529 *is_a_field_of_this
= 0;
4533 *symtab
= candidates
[0].symtab
;
4534 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4536 struct objfile
*objfile
;
4539 struct blockvector
*bv
;
4541 /* Search the list of symtabs for one which contains the
4542 address of the start of this block. */
4543 ALL_SYMTABS (objfile
, s
)
4545 bv
= BLOCKVECTOR (s
);
4546 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4547 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4548 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4551 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4553 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4557 return candidates
[0].sym
;
4560 static struct symbol
*
4561 ada_lookup_symbol_nonlocal (const char *name
,
4562 const char *linkage_name
,
4563 const struct block
*block
,
4564 const domain_enum domain
, struct symtab
**symtab
)
4566 if (linkage_name
== NULL
)
4567 linkage_name
= name
;
4568 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4573 /* True iff STR is a possible encoded suffix of a normal Ada name
4574 that is to be ignored for matching purposes. Suffixes of parallel
4575 names (e.g., XVE) are not included here. Currently, the possible suffixes
4576 are given by either of the regular expression:
4578 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4580 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4581 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4585 is_name_suffix (const char *str
)
4588 const char *matching
;
4589 const int len
= strlen (str
);
4591 /* (__[0-9]+)?\.[0-9]+ */
4593 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4596 while (isdigit (matching
[0]))
4598 if (matching
[0] == '\0')
4602 if (matching
[0] == '.')
4605 while (isdigit (matching
[0]))
4607 if (matching
[0] == '\0')
4612 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4615 while (isdigit (matching
[0]))
4617 if (matching
[0] == '\0')
4621 /* ??? We should not modify STR directly, as we are doing below. This
4622 is fine in this case, but may become problematic later if we find
4623 that this alternative did not work, and want to try matching
4624 another one from the begining of STR. Since we modified it, we
4625 won't be able to find the begining of the string anymore! */
4629 while (str
[0] != '_' && str
[0] != '\0')
4631 if (str
[0] != 'n' && str
[0] != 'b')
4636 if (str
[0] == '\000')
4640 if (str
[1] != '_' || str
[2] == '\000')
4644 if (strcmp (str
+ 3, "JM") == 0)
4646 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4647 the LJM suffix in favor of the JM one. But we will
4648 still accept LJM as a valid suffix for a reasonable
4649 amount of time, just to allow ourselves to debug programs
4650 compiled using an older version of GNAT. */
4651 if (strcmp (str
+ 3, "LJM") == 0)
4655 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4656 || str
[4] == 'U' || str
[4] == 'P')
4658 if (str
[4] == 'R' && str
[5] != 'T')
4662 if (!isdigit (str
[2]))
4664 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4665 if (!isdigit (str
[k
]) && str
[k
] != '_')
4669 if (str
[0] == '$' && isdigit (str
[1]))
4671 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4672 if (!isdigit (str
[k
]) && str
[k
] != '_')
4679 /* Return nonzero if the given string starts with a dot ('.')
4680 followed by zero or more digits.
4682 Note: brobecker/2003-11-10: A forward declaration has not been
4683 added at the begining of this file yet, because this function
4684 is only used to work around a problem found during wild matching
4685 when trying to match minimal symbol names against symbol names
4686 obtained from dwarf-2 data. This function is therefore currently
4687 only used in wild_match() and is likely to be deleted when the
4688 problem in dwarf-2 is fixed. */
4691 is_dot_digits_suffix (const char *str
)
4697 while (isdigit (str
[0]))
4699 return (str
[0] == '\0');
4702 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4703 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4704 informational suffixes of NAME (i.e., for which is_name_suffix is
4708 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4714 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4715 stored in the symbol table for nested function names is sometimes
4716 different from the name of the associated entity stored in
4717 the dwarf-2 data: This is the case for nested subprograms, where
4718 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4719 while the symbol name from the dwarf-2 data does not.
4721 Although the DWARF-2 standard documents that entity names stored
4722 in the dwarf-2 data should be identical to the name as seen in
4723 the source code, GNAT takes a different approach as we already use
4724 a special encoding mechanism to convey the information so that
4725 a C debugger can still use the information generated to debug
4726 Ada programs. A corollary is that the symbol names in the dwarf-2
4727 data should match the names found in the symbol table. I therefore
4728 consider this issue as a compiler defect.
4730 Until the compiler is properly fixed, we work-around the problem
4731 by ignoring such suffixes during the match. We do so by making
4732 a copy of PATN0 and NAME0, and then by stripping such a suffix
4733 if present. We then perform the match on the resulting strings. */
4736 name_len
= strlen (name0
);
4738 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4739 strcpy (name
, name0
);
4740 dot
= strrchr (name
, '.');
4741 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4744 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4745 strncpy (patn
, patn0
, patn_len
);
4746 patn
[patn_len
] = '\0';
4747 dot
= strrchr (patn
, '.');
4748 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4751 patn_len
= dot
- patn
;
4755 /* Now perform the wild match. */
4757 name_len
= strlen (name
);
4758 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4759 && strncmp (patn
, name
+ 5, patn_len
) == 0
4760 && is_name_suffix (name
+ patn_len
+ 5))
4763 while (name_len
>= patn_len
)
4765 if (strncmp (patn
, name
, patn_len
) == 0
4766 && is_name_suffix (name
+ patn_len
))
4774 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4779 if (!islower (name
[2]))
4786 if (!islower (name
[1]))
4797 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4798 vector *defn_symbols, updating the list of symbols in OBSTACKP
4799 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4800 OBJFILE is the section containing BLOCK.
4801 SYMTAB is recorded with each symbol added. */
4804 ada_add_block_symbols (struct obstack
*obstackp
,
4805 struct block
*block
, const char *name
,
4806 domain_enum domain
, struct objfile
*objfile
,
4807 struct symtab
*symtab
, int wild
)
4809 struct dict_iterator iter
;
4810 int name_len
= strlen (name
);
4811 /* A matching argument symbol, if any. */
4812 struct symbol
*arg_sym
;
4813 /* Set true when we find a matching non-argument symbol. */
4822 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4824 if (SYMBOL_DOMAIN (sym
) == domain
4825 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
4827 switch (SYMBOL_CLASS (sym
))
4833 case LOC_REGPARM_ADDR
:
4834 case LOC_BASEREG_ARG
:
4835 case LOC_COMPUTED_ARG
:
4838 case LOC_UNRESOLVED
:
4842 add_defn_to_vec (obstackp
,
4843 fixup_symbol_section (sym
, objfile
),
4852 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4854 if (SYMBOL_DOMAIN (sym
) == domain
)
4856 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
4858 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
4860 switch (SYMBOL_CLASS (sym
))
4866 case LOC_REGPARM_ADDR
:
4867 case LOC_BASEREG_ARG
:
4868 case LOC_COMPUTED_ARG
:
4871 case LOC_UNRESOLVED
:
4875 add_defn_to_vec (obstackp
,
4876 fixup_symbol_section (sym
, objfile
),
4885 if (!found_sym
&& arg_sym
!= NULL
)
4887 add_defn_to_vec (obstackp
,
4888 fixup_symbol_section (arg_sym
, objfile
),
4897 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4899 if (SYMBOL_DOMAIN (sym
) == domain
)
4903 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
4906 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
4908 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
4913 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
4915 switch (SYMBOL_CLASS (sym
))
4921 case LOC_REGPARM_ADDR
:
4922 case LOC_BASEREG_ARG
:
4923 case LOC_COMPUTED_ARG
:
4926 case LOC_UNRESOLVED
:
4930 add_defn_to_vec (obstackp
,
4931 fixup_symbol_section (sym
, objfile
),
4939 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4940 They aren't parameters, right? */
4941 if (!found_sym
&& arg_sym
!= NULL
)
4943 add_defn_to_vec (obstackp
,
4944 fixup_symbol_section (arg_sym
, objfile
),
4952 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
4953 to be invisible to users. */
4956 ada_is_ignored_field (struct type
*type
, int field_num
)
4958 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
4962 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
4963 return (name
== NULL
4964 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
4968 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
4969 pointer or reference type whose ultimate target has a tag field. */
4972 ada_is_tagged_type (struct type
*type
, int refok
)
4974 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
4977 /* True iff TYPE represents the type of X'Tag */
4980 ada_is_tag_type (struct type
*type
)
4982 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
4986 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
4987 return (name
!= NULL
4988 && strcmp (name
, "ada__tags__dispatch_table") == 0);
4992 /* The type of the tag on VAL. */
4995 ada_tag_type (struct value
*val
)
4997 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
5000 /* The value of the tag on VAL. */
5003 ada_value_tag (struct value
*val
)
5005 return ada_value_struct_elt (val
, "_tag", "record");
5008 /* The value of the tag on the object of type TYPE whose contents are
5009 saved at VALADDR, if it is non-null, or is at memory address
5012 static struct value
*
5013 value_tag_from_contents_and_address (struct type
*type
,
5014 const gdb_byte
*valaddr
,
5017 int tag_byte_offset
, dummy1
, dummy2
;
5018 struct type
*tag_type
;
5019 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5022 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5024 : valaddr
+ tag_byte_offset
);
5025 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5027 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5032 static struct type
*
5033 type_from_tag (struct value
*tag
)
5035 const char *type_name
= ada_tag_name (tag
);
5036 if (type_name
!= NULL
)
5037 return ada_find_any_type (ada_encode (type_name
));
5047 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5048 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5049 The value stored in ARGS->name is valid until the next call to
5053 ada_tag_name_1 (void *args0
)
5055 struct tag_args
*args
= (struct tag_args
*) args0
;
5056 static char name
[1024];
5060 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
5063 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
5066 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5067 for (p
= name
; *p
!= '\0'; p
+= 1)
5074 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5078 ada_tag_name (struct value
*tag
)
5080 struct tag_args args
;
5081 if (!ada_is_tag_type (value_type (tag
)))
5085 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5089 /* The parent type of TYPE, or NULL if none. */
5092 ada_parent_type (struct type
*type
)
5096 type
= ada_check_typedef (type
);
5098 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5101 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5102 if (ada_is_parent_field (type
, i
))
5103 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5108 /* True iff field number FIELD_NUM of structure type TYPE contains the
5109 parent-type (inherited) fields of a derived type. Assumes TYPE is
5110 a structure type with at least FIELD_NUM+1 fields. */
5113 ada_is_parent_field (struct type
*type
, int field_num
)
5115 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5116 return (name
!= NULL
5117 && (strncmp (name
, "PARENT", 6) == 0
5118 || strncmp (name
, "_parent", 7) == 0));
5121 /* True iff field number FIELD_NUM of structure type TYPE is a
5122 transparent wrapper field (which should be silently traversed when doing
5123 field selection and flattened when printing). Assumes TYPE is a
5124 structure type with at least FIELD_NUM+1 fields. Such fields are always
5128 ada_is_wrapper_field (struct type
*type
, int field_num
)
5130 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5131 return (name
!= NULL
5132 && (strncmp (name
, "PARENT", 6) == 0
5133 || strcmp (name
, "REP") == 0
5134 || strncmp (name
, "_parent", 7) == 0
5135 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5138 /* True iff field number FIELD_NUM of structure or union type TYPE
5139 is a variant wrapper. Assumes TYPE is a structure type with at least
5140 FIELD_NUM+1 fields. */
5143 ada_is_variant_part (struct type
*type
, int field_num
)
5145 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5146 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5147 || (is_dynamic_field (type
, field_num
)
5148 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5149 == TYPE_CODE_UNION
)));
5152 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5153 whose discriminants are contained in the record type OUTER_TYPE,
5154 returns the type of the controlling discriminant for the variant. */
5157 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5159 char *name
= ada_variant_discrim_name (var_type
);
5161 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5163 return builtin_type_int
;
5168 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5169 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5170 represents a 'when others' clause; otherwise 0. */
5173 ada_is_others_clause (struct type
*type
, int field_num
)
5175 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5176 return (name
!= NULL
&& name
[0] == 'O');
5179 /* Assuming that TYPE0 is the type of the variant part of a record,
5180 returns the name of the discriminant controlling the variant.
5181 The value is valid until the next call to ada_variant_discrim_name. */
5184 ada_variant_discrim_name (struct type
*type0
)
5186 static char *result
= NULL
;
5187 static size_t result_len
= 0;
5190 const char *discrim_end
;
5191 const char *discrim_start
;
5193 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5194 type
= TYPE_TARGET_TYPE (type0
);
5198 name
= ada_type_name (type
);
5200 if (name
== NULL
|| name
[0] == '\000')
5203 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5206 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5209 if (discrim_end
== name
)
5212 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5215 if (discrim_start
== name
+ 1)
5217 if ((discrim_start
> name
+ 3
5218 && strncmp (discrim_start
- 3, "___", 3) == 0)
5219 || discrim_start
[-1] == '.')
5223 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5224 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5225 result
[discrim_end
- discrim_start
] = '\0';
5229 /* Scan STR for a subtype-encoded number, beginning at position K.
5230 Put the position of the character just past the number scanned in
5231 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5232 Return 1 if there was a valid number at the given position, and 0
5233 otherwise. A "subtype-encoded" number consists of the absolute value
5234 in decimal, followed by the letter 'm' to indicate a negative number.
5235 Assumes 0m does not occur. */
5238 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5242 if (!isdigit (str
[k
]))
5245 /* Do it the hard way so as not to make any assumption about
5246 the relationship of unsigned long (%lu scan format code) and
5249 while (isdigit (str
[k
]))
5251 RU
= RU
* 10 + (str
[k
] - '0');
5258 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5264 /* NOTE on the above: Technically, C does not say what the results of
5265 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5266 number representable as a LONGEST (although either would probably work
5267 in most implementations). When RU>0, the locution in the then branch
5268 above is always equivalent to the negative of RU. */
5275 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5276 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5277 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5280 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5282 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5295 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5304 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5305 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5307 if (val
>= L
&& val
<= U
)
5319 /* FIXME: Lots of redundancy below. Try to consolidate. */
5321 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5322 ARG_TYPE, extract and return the value of one of its (non-static)
5323 fields. FIELDNO says which field. Differs from value_primitive_field
5324 only in that it can handle packed values of arbitrary type. */
5326 static struct value
*
5327 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5328 struct type
*arg_type
)
5332 arg_type
= ada_check_typedef (arg_type
);
5333 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5335 /* Handle packed fields. */
5337 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5339 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5340 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5342 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5343 offset
+ bit_pos
/ 8,
5344 bit_pos
% 8, bit_size
, type
);
5347 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5350 /* Find field with name NAME in object of type TYPE. If found, return 1
5351 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
5352 OFFSET + the byte offset of the field within an object of that type,
5353 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
5354 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
5355 Looks inside wrappers for the field. Returns 0 if field not
5358 find_struct_field (char *name
, struct type
*type
, int offset
,
5359 struct type
**field_type_p
,
5360 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
5364 type
= ada_check_typedef (type
);
5365 *field_type_p
= NULL
;
5366 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
5368 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5370 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
5371 int fld_offset
= offset
+ bit_pos
/ 8;
5372 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5374 if (t_field_name
== NULL
)
5377 else if (field_name_match (t_field_name
, name
))
5379 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
5380 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
5381 *byte_offset_p
= fld_offset
;
5382 *bit_offset_p
= bit_pos
% 8;
5383 *bit_size_p
= bit_size
;
5386 else if (ada_is_wrapper_field (type
, i
))
5388 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
5389 field_type_p
, byte_offset_p
, bit_offset_p
,
5393 else if (ada_is_variant_part (type
, i
))
5396 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5398 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5400 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
5402 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5403 field_type_p
, byte_offset_p
,
5404 bit_offset_p
, bit_size_p
))
5414 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5415 and search in it assuming it has (class) type TYPE.
5416 If found, return value, else return NULL.
5418 Searches recursively through wrapper fields (e.g., '_parent'). */
5420 static struct value
*
5421 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5425 type
= ada_check_typedef (type
);
5427 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5429 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5431 if (t_field_name
== NULL
)
5434 else if (field_name_match (t_field_name
, name
))
5435 return ada_value_primitive_field (arg
, offset
, i
, type
);
5437 else if (ada_is_wrapper_field (type
, i
))
5439 struct value
*v
= /* Do not let indent join lines here. */
5440 ada_search_struct_field (name
, arg
,
5441 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5442 TYPE_FIELD_TYPE (type
, i
));
5447 else if (ada_is_variant_part (type
, i
))
5450 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5451 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5453 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5455 struct value
*v
= ada_search_struct_field
/* Force line break. */
5457 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5458 TYPE_FIELD_TYPE (field_type
, j
));
5467 /* Given ARG, a value of type (pointer or reference to a)*
5468 structure/union, extract the component named NAME from the ultimate
5469 target structure/union and return it as a value with its
5470 appropriate type. If ARG is a pointer or reference and the field
5471 is not packed, returns a reference to the field, otherwise the
5472 value of the field (an lvalue if ARG is an lvalue).
5474 The routine searches for NAME among all members of the structure itself
5475 and (recursively) among all members of any wrapper members
5478 ERR is a name (for use in error messages) that identifies the class
5479 of entity that ARG is supposed to be. ERR may be null, indicating
5480 that on error, the function simply returns NULL, and does not
5481 throw an error. (FIXME: True only if ARG is a pointer or reference
5485 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5487 struct type
*t
, *t1
;
5491 t1
= t
= ada_check_typedef (value_type (arg
));
5492 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5494 t1
= TYPE_TARGET_TYPE (t
);
5500 error (_("Bad value type in a %s."), err
);
5502 t1
= ada_check_typedef (t1
);
5503 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5505 arg
= coerce_ref (arg
);
5510 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5512 t1
= TYPE_TARGET_TYPE (t
);
5518 error (_("Bad value type in a %s."), err
);
5520 t1
= ada_check_typedef (t1
);
5521 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5523 arg
= value_ind (arg
);
5530 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
5535 error (_("Attempt to extract a component of a value that is not a %s."),
5540 v
= ada_search_struct_field (name
, arg
, 0, t
);
5543 int bit_offset
, bit_size
, byte_offset
;
5544 struct type
*field_type
;
5547 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5548 address
= value_as_address (arg
);
5550 address
= unpack_pointer (t
, value_contents (arg
));
5552 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
5553 if (find_struct_field (name
, t1
, 0,
5554 &field_type
, &byte_offset
, &bit_offset
,
5559 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5560 arg
= ada_coerce_ref (arg
);
5562 arg
= ada_value_ind (arg
);
5563 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
5564 bit_offset
, bit_size
,
5568 v
= value_from_pointer (lookup_reference_type (field_type
),
5569 address
+ byte_offset
);
5573 if (v
== NULL
&& err
!= NULL
)
5574 error (_("There is no member named %s."), name
);
5579 /* Given a type TYPE, look up the type of the component of type named NAME.
5580 If DISPP is non-null, add its byte displacement from the beginning of a
5581 structure (pointed to by a value) of type TYPE to *DISPP (does not
5582 work for packed fields).
5584 Matches any field whose name has NAME as a prefix, possibly
5587 TYPE can be either a struct or union. If REFOK, TYPE may also
5588 be a (pointer or reference)+ to a struct or union, and the
5589 ultimate target type will be searched.
5591 Looks recursively into variant clauses and parent types.
5593 If NOERR is nonzero, return NULL if NAME is not suitably defined or
5594 TYPE is not a type of the right kind. */
5596 static struct type
*
5597 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
5598 int noerr
, int *dispp
)
5605 if (refok
&& type
!= NULL
)
5608 type
= ada_check_typedef (type
);
5609 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5610 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5612 type
= TYPE_TARGET_TYPE (type
);
5616 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
5617 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
5623 target_terminal_ours ();
5624 gdb_flush (gdb_stdout
);
5626 error (_("Type (null) is not a structure or union type"));
5629 /* XXX: type_sprint */
5630 fprintf_unfiltered (gdb_stderr
, _("Type "));
5631 type_print (type
, "", gdb_stderr
, -1);
5632 error (_(" is not a structure or union type"));
5637 type
= to_static_fixed_type (type
);
5639 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5641 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5645 if (t_field_name
== NULL
)
5648 else if (field_name_match (t_field_name
, name
))
5651 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5652 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5655 else if (ada_is_wrapper_field (type
, i
))
5658 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5663 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5668 else if (ada_is_variant_part (type
, i
))
5671 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5673 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5676 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5681 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5692 target_terminal_ours ();
5693 gdb_flush (gdb_stdout
);
5696 /* XXX: type_sprint */
5697 fprintf_unfiltered (gdb_stderr
, _("Type "));
5698 type_print (type
, "", gdb_stderr
, -1);
5699 error (_(" has no component named <null>"));
5703 /* XXX: type_sprint */
5704 fprintf_unfiltered (gdb_stderr
, _("Type "));
5705 type_print (type
, "", gdb_stderr
, -1);
5706 error (_(" has no component named %s"), name
);
5713 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5714 within a value of type OUTER_TYPE that is stored in GDB at
5715 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5716 numbering from 0) is applicable. Returns -1 if none are. */
5719 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5720 const gdb_byte
*outer_valaddr
)
5725 struct type
*discrim_type
;
5726 char *discrim_name
= ada_variant_discrim_name (var_type
);
5727 LONGEST discrim_val
;
5731 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
5732 if (discrim_type
== NULL
)
5734 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5737 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5739 if (ada_is_others_clause (var_type
, i
))
5741 else if (ada_in_variant (discrim_val
, var_type
, i
))
5745 return others_clause
;
5750 /* Dynamic-Sized Records */
5752 /* Strategy: The type ostensibly attached to a value with dynamic size
5753 (i.e., a size that is not statically recorded in the debugging
5754 data) does not accurately reflect the size or layout of the value.
5755 Our strategy is to convert these values to values with accurate,
5756 conventional types that are constructed on the fly. */
5758 /* There is a subtle and tricky problem here. In general, we cannot
5759 determine the size of dynamic records without its data. However,
5760 the 'struct value' data structure, which GDB uses to represent
5761 quantities in the inferior process (the target), requires the size
5762 of the type at the time of its allocation in order to reserve space
5763 for GDB's internal copy of the data. That's why the
5764 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5765 rather than struct value*s.
5767 However, GDB's internal history variables ($1, $2, etc.) are
5768 struct value*s containing internal copies of the data that are not, in
5769 general, the same as the data at their corresponding addresses in
5770 the target. Fortunately, the types we give to these values are all
5771 conventional, fixed-size types (as per the strategy described
5772 above), so that we don't usually have to perform the
5773 'to_fixed_xxx_type' conversions to look at their values.
5774 Unfortunately, there is one exception: if one of the internal
5775 history variables is an array whose elements are unconstrained
5776 records, then we will need to create distinct fixed types for each
5777 element selected. */
5779 /* The upshot of all of this is that many routines take a (type, host
5780 address, target address) triple as arguments to represent a value.
5781 The host address, if non-null, is supposed to contain an internal
5782 copy of the relevant data; otherwise, the program is to consult the
5783 target at the target address. */
5785 /* Assuming that VAL0 represents a pointer value, the result of
5786 dereferencing it. Differs from value_ind in its treatment of
5787 dynamic-sized types. */
5790 ada_value_ind (struct value
*val0
)
5792 struct value
*val
= unwrap_value (value_ind (val0
));
5793 return ada_to_fixed_value (val
);
5796 /* The value resulting from dereferencing any "reference to"
5797 qualifiers on VAL0. */
5799 static struct value
*
5800 ada_coerce_ref (struct value
*val0
)
5802 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
5804 struct value
*val
= val0
;
5805 val
= coerce_ref (val
);
5806 val
= unwrap_value (val
);
5807 return ada_to_fixed_value (val
);
5813 /* Return OFF rounded upward if necessary to a multiple of
5814 ALIGNMENT (a power of 2). */
5817 align_value (unsigned int off
, unsigned int alignment
)
5819 return (off
+ alignment
- 1) & ~(alignment
- 1);
5822 /* Return the bit alignment required for field #F of template type TYPE. */
5825 field_alignment (struct type
*type
, int f
)
5827 const char *name
= TYPE_FIELD_NAME (type
, f
);
5828 int len
= (name
== NULL
) ? 0 : strlen (name
);
5831 if (!isdigit (name
[len
- 1]))
5834 if (isdigit (name
[len
- 2]))
5835 align_offset
= len
- 2;
5837 align_offset
= len
- 1;
5839 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
5840 return TARGET_CHAR_BIT
;
5842 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5845 /* Find a symbol named NAME. Ignores ambiguity. */
5848 ada_find_any_symbol (const char *name
)
5852 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
5853 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5856 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
5860 /* Find a type named NAME. Ignores ambiguity. */
5863 ada_find_any_type (const char *name
)
5865 struct symbol
*sym
= ada_find_any_symbol (name
);
5868 return SYMBOL_TYPE (sym
);
5873 /* Given a symbol NAME and its associated BLOCK, search all symbols
5874 for its ___XR counterpart, which is the ``renaming'' symbol
5875 associated to NAME. Return this symbol if found, return
5879 ada_find_renaming_symbol (const char *name
, struct block
*block
)
5881 const struct symbol
*function_sym
= block_function (block
);
5884 if (function_sym
!= NULL
)
5886 /* If the symbol is defined inside a function, NAME is not fully
5887 qualified. This means we need to prepend the function name
5888 as well as adding the ``___XR'' suffix to build the name of
5889 the associated renaming symbol. */
5890 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
5891 const int function_name_len
= strlen (function_name
);
5892 const int rename_len
= function_name_len
+ 2 /* "__" */
5893 + strlen (name
) + 6 /* "___XR\0" */ ;
5895 /* Library-level functions are a special case, as GNAT adds
5896 a ``_ada_'' prefix to the function name to avoid namespace
5897 pollution. However, the renaming symbol themselves do not
5898 have this prefix, so we need to skip this prefix if present. */
5899 if (function_name_len
> 5 /* "_ada_" */
5900 && strstr (function_name
, "_ada_") == function_name
)
5901 function_name
= function_name
+ 5;
5903 rename
= (char *) alloca (rename_len
* sizeof (char));
5904 sprintf (rename
, "%s__%s___XR", function_name
, name
);
5908 const int rename_len
= strlen (name
) + 6;
5909 rename
= (char *) alloca (rename_len
* sizeof (char));
5910 sprintf (rename
, "%s___XR", name
);
5913 return ada_find_any_symbol (rename
);
5916 /* Because of GNAT encoding conventions, several GDB symbols may match a
5917 given type name. If the type denoted by TYPE0 is to be preferred to
5918 that of TYPE1 for purposes of type printing, return non-zero;
5919 otherwise return 0. */
5922 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5926 else if (type0
== NULL
)
5928 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5930 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5932 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
5934 else if (ada_is_packed_array_type (type0
))
5936 else if (ada_is_array_descriptor_type (type0
)
5937 && !ada_is_array_descriptor_type (type1
))
5939 else if (ada_renaming_type (type0
) != NULL
5940 && ada_renaming_type (type1
) == NULL
)
5945 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5946 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5949 ada_type_name (struct type
*type
)
5953 else if (TYPE_NAME (type
) != NULL
)
5954 return TYPE_NAME (type
);
5956 return TYPE_TAG_NAME (type
);
5959 /* Find a parallel type to TYPE whose name is formed by appending
5960 SUFFIX to the name of TYPE. */
5963 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5966 static size_t name_len
= 0;
5968 char *typename
= ada_type_name (type
);
5970 if (typename
== NULL
)
5973 len
= strlen (typename
);
5975 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5977 strcpy (name
, typename
);
5978 strcpy (name
+ len
, suffix
);
5980 return ada_find_any_type (name
);
5984 /* If TYPE is a variable-size record type, return the corresponding template
5985 type describing its fields. Otherwise, return NULL. */
5987 static struct type
*
5988 dynamic_template_type (struct type
*type
)
5990 type
= ada_check_typedef (type
);
5992 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5993 || ada_type_name (type
) == NULL
)
5997 int len
= strlen (ada_type_name (type
));
5998 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6001 return ada_find_parallel_type (type
, "___XVE");
6005 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6006 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6009 is_dynamic_field (struct type
*templ_type
, int field_num
)
6011 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6013 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6014 && strstr (name
, "___XVL") != NULL
;
6017 /* The index of the variant field of TYPE, or -1 if TYPE does not
6018 represent a variant record type. */
6021 variant_field_index (struct type
*type
)
6025 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6028 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6030 if (ada_is_variant_part (type
, f
))
6036 /* A record type with no fields. */
6038 static struct type
*
6039 empty_record (struct objfile
*objfile
)
6041 struct type
*type
= alloc_type (objfile
);
6042 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6043 TYPE_NFIELDS (type
) = 0;
6044 TYPE_FIELDS (type
) = NULL
;
6045 TYPE_NAME (type
) = "<empty>";
6046 TYPE_TAG_NAME (type
) = NULL
;
6047 TYPE_FLAGS (type
) = 0;
6048 TYPE_LENGTH (type
) = 0;
6052 /* An ordinary record type (with fixed-length fields) that describes
6053 the value of type TYPE at VALADDR or ADDRESS (see comments at
6054 the beginning of this section) VAL according to GNAT conventions.
6055 DVAL0 should describe the (portion of a) record that contains any
6056 necessary discriminants. It should be NULL if value_type (VAL) is
6057 an outer-level type (i.e., as opposed to a branch of a variant.) A
6058 variant field (unless unchecked) is replaced by a particular branch
6061 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6062 length are not statically known are discarded. As a consequence,
6063 VALADDR, ADDRESS and DVAL0 are ignored.
6065 NOTE: Limitations: For now, we assume that dynamic fields and
6066 variants occupy whole numbers of bytes. However, they need not be
6070 ada_template_to_fixed_record_type_1 (struct type
*type
,
6071 const gdb_byte
*valaddr
,
6072 CORE_ADDR address
, struct value
*dval0
,
6073 int keep_dynamic_fields
)
6075 struct value
*mark
= value_mark ();
6078 int nfields
, bit_len
;
6081 int fld_bit_len
, bit_incr
;
6084 /* Compute the number of fields in this record type that are going
6085 to be processed: unless keep_dynamic_fields, this includes only
6086 fields whose position and length are static will be processed. */
6087 if (keep_dynamic_fields
)
6088 nfields
= TYPE_NFIELDS (type
);
6092 while (nfields
< TYPE_NFIELDS (type
)
6093 && !ada_is_variant_part (type
, nfields
)
6094 && !is_dynamic_field (type
, nfields
))
6098 rtype
= alloc_type (TYPE_OBJFILE (type
));
6099 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6100 INIT_CPLUS_SPECIFIC (rtype
);
6101 TYPE_NFIELDS (rtype
) = nfields
;
6102 TYPE_FIELDS (rtype
) = (struct field
*)
6103 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6104 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6105 TYPE_NAME (rtype
) = ada_type_name (type
);
6106 TYPE_TAG_NAME (rtype
) = NULL
;
6107 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6113 for (f
= 0; f
< nfields
; f
+= 1)
6115 off
= align_value (off
, field_alignment (type
, f
))
6116 + TYPE_FIELD_BITPOS (type
, f
);
6117 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6118 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6120 if (ada_is_variant_part (type
, f
))
6123 fld_bit_len
= bit_incr
= 0;
6125 else if (is_dynamic_field (type
, f
))
6128 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6132 TYPE_FIELD_TYPE (rtype
, f
) =
6135 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6136 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6137 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6138 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6139 bit_incr
= fld_bit_len
=
6140 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6144 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6145 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6146 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6147 bit_incr
= fld_bit_len
=
6148 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6150 bit_incr
= fld_bit_len
=
6151 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6153 if (off
+ fld_bit_len
> bit_len
)
6154 bit_len
= off
+ fld_bit_len
;
6156 TYPE_LENGTH (rtype
) =
6157 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6160 /* We handle the variant part, if any, at the end because of certain
6161 odd cases in which it is re-ordered so as NOT the last field of
6162 the record. This can happen in the presence of representation
6164 if (variant_field
>= 0)
6166 struct type
*branch_type
;
6168 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6171 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6176 to_fixed_variant_branch_type
6177 (TYPE_FIELD_TYPE (type
, variant_field
),
6178 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6179 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6180 if (branch_type
== NULL
)
6182 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6183 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6184 TYPE_NFIELDS (rtype
) -= 1;
6188 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6189 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6191 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6193 if (off
+ fld_bit_len
> bit_len
)
6194 bit_len
= off
+ fld_bit_len
;
6195 TYPE_LENGTH (rtype
) =
6196 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6200 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6201 should contain the alignment of that record, which should be a strictly
6202 positive value. If null or negative, then something is wrong, most
6203 probably in the debug info. In that case, we don't round up the size
6204 of the resulting type. If this record is not part of another structure,
6205 the current RTYPE length might be good enough for our purposes. */
6206 if (TYPE_LENGTH (type
) <= 0)
6208 if (TYPE_NAME (rtype
))
6209 warning (_("Invalid type size for `%s' detected: %d."),
6210 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6212 warning (_("Invalid type size for <unnamed> detected: %d."),
6213 TYPE_LENGTH (type
));
6217 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6218 TYPE_LENGTH (type
));
6221 value_free_to_mark (mark
);
6222 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6223 error (_("record type with dynamic size is larger than varsize-limit"));
6227 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6230 static struct type
*
6231 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
6232 CORE_ADDR address
, struct value
*dval0
)
6234 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6238 /* An ordinary record type in which ___XVL-convention fields and
6239 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6240 static approximations, containing all possible fields. Uses
6241 no runtime values. Useless for use in values, but that's OK,
6242 since the results are used only for type determinations. Works on both
6243 structs and unions. Representation note: to save space, we memorize
6244 the result of this function in the TYPE_TARGET_TYPE of the
6247 static struct type
*
6248 template_to_static_fixed_type (struct type
*type0
)
6254 if (TYPE_TARGET_TYPE (type0
) != NULL
)
6255 return TYPE_TARGET_TYPE (type0
);
6257 nfields
= TYPE_NFIELDS (type0
);
6260 for (f
= 0; f
< nfields
; f
+= 1)
6262 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
6263 struct type
*new_type
;
6265 if (is_dynamic_field (type0
, f
))
6266 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
6268 new_type
= to_static_fixed_type (field_type
);
6269 if (type
== type0
&& new_type
!= field_type
)
6271 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
6272 TYPE_CODE (type
) = TYPE_CODE (type0
);
6273 INIT_CPLUS_SPECIFIC (type
);
6274 TYPE_NFIELDS (type
) = nfields
;
6275 TYPE_FIELDS (type
) = (struct field
*)
6276 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6277 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
6278 sizeof (struct field
) * nfields
);
6279 TYPE_NAME (type
) = ada_type_name (type0
);
6280 TYPE_TAG_NAME (type
) = NULL
;
6281 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
6282 TYPE_LENGTH (type
) = 0;
6284 TYPE_FIELD_TYPE (type
, f
) = new_type
;
6285 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
6290 /* Given an object of type TYPE whose contents are at VALADDR and
6291 whose address in memory is ADDRESS, returns a revision of TYPE --
6292 a non-dynamic-sized record with a variant part -- in which
6293 the variant part is replaced with the appropriate branch. Looks
6294 for discriminant values in DVAL0, which can be NULL if the record
6295 contains the necessary discriminant values. */
6297 static struct type
*
6298 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
6299 CORE_ADDR address
, struct value
*dval0
)
6301 struct value
*mark
= value_mark ();
6304 struct type
*branch_type
;
6305 int nfields
= TYPE_NFIELDS (type
);
6306 int variant_field
= variant_field_index (type
);
6308 if (variant_field
== -1)
6312 dval
= value_from_contents_and_address (type
, valaddr
, address
);
6316 rtype
= alloc_type (TYPE_OBJFILE (type
));
6317 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6318 INIT_CPLUS_SPECIFIC (rtype
);
6319 TYPE_NFIELDS (rtype
) = nfields
;
6320 TYPE_FIELDS (rtype
) =
6321 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6322 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6323 sizeof (struct field
) * nfields
);
6324 TYPE_NAME (rtype
) = ada_type_name (type
);
6325 TYPE_TAG_NAME (rtype
) = NULL
;
6326 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6327 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6329 branch_type
= to_fixed_variant_branch_type
6330 (TYPE_FIELD_TYPE (type
, variant_field
),
6331 cond_offset_host (valaddr
,
6332 TYPE_FIELD_BITPOS (type
, variant_field
)
6334 cond_offset_target (address
,
6335 TYPE_FIELD_BITPOS (type
, variant_field
)
6336 / TARGET_CHAR_BIT
), dval
);
6337 if (branch_type
== NULL
)
6340 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
6341 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6342 TYPE_NFIELDS (rtype
) -= 1;
6346 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6347 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6348 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
6349 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6351 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
6353 value_free_to_mark (mark
);
6357 /* An ordinary record type (with fixed-length fields) that describes
6358 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6359 beginning of this section]. Any necessary discriminants' values
6360 should be in DVAL, a record value; it may be NULL if the object
6361 at ADDR itself contains any necessary discriminant values.
6362 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6363 values from the record are needed. Except in the case that DVAL,
6364 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6365 unchecked) is replaced by a particular branch of the variant.
6367 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6368 is questionable and may be removed. It can arise during the
6369 processing of an unconstrained-array-of-record type where all the
6370 variant branches have exactly the same size. This is because in
6371 such cases, the compiler does not bother to use the XVS convention
6372 when encoding the record. I am currently dubious of this
6373 shortcut and suspect the compiler should be altered. FIXME. */
6375 static struct type
*
6376 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
6377 CORE_ADDR address
, struct value
*dval
)
6379 struct type
*templ_type
;
6381 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6384 templ_type
= dynamic_template_type (type0
);
6386 if (templ_type
!= NULL
)
6387 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6388 else if (variant_field_index (type0
) >= 0)
6390 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
6392 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
6397 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
6403 /* An ordinary record type (with fixed-length fields) that describes
6404 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6405 union type. Any necessary discriminants' values should be in DVAL,
6406 a record value. That is, this routine selects the appropriate
6407 branch of the union at ADDR according to the discriminant value
6408 indicated in the union's type name. */
6410 static struct type
*
6411 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
6412 CORE_ADDR address
, struct value
*dval
)
6415 struct type
*templ_type
;
6416 struct type
*var_type
;
6418 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6419 var_type
= TYPE_TARGET_TYPE (var_type0
);
6421 var_type
= var_type0
;
6423 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6425 if (templ_type
!= NULL
)
6426 var_type
= templ_type
;
6429 ada_which_variant_applies (var_type
,
6430 value_type (dval
), value_contents (dval
));
6433 return empty_record (TYPE_OBJFILE (var_type
));
6434 else if (is_dynamic_field (var_type
, which
))
6435 return to_fixed_record_type
6436 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6437 valaddr
, address
, dval
);
6438 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
6440 to_fixed_record_type
6441 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6443 return TYPE_FIELD_TYPE (var_type
, which
);
6446 /* Assuming that TYPE0 is an array type describing the type of a value
6447 at ADDR, and that DVAL describes a record containing any
6448 discriminants used in TYPE0, returns a type for the value that
6449 contains no dynamic components (that is, no components whose sizes
6450 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6451 true, gives an error message if the resulting type's size is over
6454 static struct type
*
6455 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6458 struct type
*index_type_desc
;
6459 struct type
*result
;
6461 if (ada_is_packed_array_type (type0
) /* revisit? */
6462 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
6465 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6466 if (index_type_desc
== NULL
)
6468 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
6469 /* NOTE: elt_type---the fixed version of elt_type0---should never
6470 depend on the contents of the array in properly constructed
6472 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6474 if (elt_type0
== elt_type
)
6477 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6478 elt_type
, TYPE_INDEX_TYPE (type0
));
6483 struct type
*elt_type0
;
6486 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6487 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6489 /* NOTE: result---the fixed version of elt_type0---should never
6490 depend on the contents of the array in properly constructed
6492 result
= ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
);
6493 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6495 struct type
*range_type
=
6496 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6497 dval
, TYPE_OBJFILE (type0
));
6498 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6499 result
, range_type
);
6501 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6502 error (_("array type with dynamic size is larger than varsize-limit"));
6505 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
6510 /* A standard type (containing no dynamically sized components)
6511 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6512 DVAL describes a record containing any discriminants used in TYPE0,
6513 and may be NULL if there are none, or if the object of type TYPE at
6514 ADDRESS or in VALADDR contains these discriminants. */
6517 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
6518 CORE_ADDR address
, struct value
*dval
)
6520 type
= ada_check_typedef (type
);
6521 switch (TYPE_CODE (type
))
6525 case TYPE_CODE_STRUCT
:
6527 struct type
*static_type
= to_static_fixed_type (type
);
6528 if (ada_is_tagged_type (static_type
, 0))
6530 struct type
*real_type
=
6531 type_from_tag (value_tag_from_contents_and_address (static_type
,
6534 if (real_type
!= NULL
)
6537 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6539 case TYPE_CODE_ARRAY
:
6540 return to_fixed_array_type (type
, dval
, 1);
6541 case TYPE_CODE_UNION
:
6545 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6549 /* A standard (static-sized) type corresponding as well as possible to
6550 TYPE0, but based on no runtime data. */
6552 static struct type
*
6553 to_static_fixed_type (struct type
*type0
)
6560 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6563 type0
= ada_check_typedef (type0
);
6565 switch (TYPE_CODE (type0
))
6569 case TYPE_CODE_STRUCT
:
6570 type
= dynamic_template_type (type0
);
6572 return template_to_static_fixed_type (type
);
6574 return template_to_static_fixed_type (type0
);
6575 case TYPE_CODE_UNION
:
6576 type
= ada_find_parallel_type (type0
, "___XVU");
6578 return template_to_static_fixed_type (type
);
6580 return template_to_static_fixed_type (type0
);
6584 /* A static approximation of TYPE with all type wrappers removed. */
6586 static struct type
*
6587 static_unwrap_type (struct type
*type
)
6589 if (ada_is_aligner_type (type
))
6591 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
6592 if (ada_type_name (type1
) == NULL
)
6593 TYPE_NAME (type1
) = ada_type_name (type
);
6595 return static_unwrap_type (type1
);
6599 struct type
*raw_real_type
= ada_get_base_type (type
);
6600 if (raw_real_type
== type
)
6603 return to_static_fixed_type (raw_real_type
);
6607 /* In some cases, incomplete and private types require
6608 cross-references that are not resolved as records (for example,
6610 type FooP is access Foo;
6612 type Foo is array ...;
6613 ). In these cases, since there is no mechanism for producing
6614 cross-references to such types, we instead substitute for FooP a
6615 stub enumeration type that is nowhere resolved, and whose tag is
6616 the name of the actual type. Call these types "non-record stubs". */
6618 /* A type equivalent to TYPE that is not a non-record stub, if one
6619 exists, otherwise TYPE. */
6622 ada_check_typedef (struct type
*type
)
6624 CHECK_TYPEDEF (type
);
6625 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6626 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6627 || TYPE_TAG_NAME (type
) == NULL
)
6631 char *name
= TYPE_TAG_NAME (type
);
6632 struct type
*type1
= ada_find_any_type (name
);
6633 return (type1
== NULL
) ? type
: type1
;
6637 /* A value representing the data at VALADDR/ADDRESS as described by
6638 type TYPE0, but with a standard (static-sized) type that correctly
6639 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6640 type, then return VAL0 [this feature is simply to avoid redundant
6641 creation of struct values]. */
6643 static struct value
*
6644 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
6647 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
6648 if (type
== type0
&& val0
!= NULL
)
6651 return value_from_contents_and_address (type
, 0, address
);
6654 /* A value representing VAL, but with a standard (static-sized) type
6655 that correctly describes it. Does not necessarily create a new
6658 static struct value
*
6659 ada_to_fixed_value (struct value
*val
)
6661 return ada_to_fixed_value_create (value_type (val
),
6662 VALUE_ADDRESS (val
) + value_offset (val
),
6666 /* A value representing VAL, but with a standard (static-sized) type
6667 chosen to approximate the real type of VAL as well as possible, but
6668 without consulting any runtime values. For Ada dynamic-sized
6669 types, therefore, the type of the result is likely to be inaccurate. */
6672 ada_to_static_fixed_value (struct value
*val
)
6675 to_static_fixed_type (static_unwrap_type (value_type (val
)));
6676 if (type
== value_type (val
))
6679 return coerce_unspec_val_to_type (val
, type
);
6685 /* Table mapping attribute numbers to names.
6686 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
6688 static const char *attribute_names
[] = {
6706 ada_attribute_name (enum exp_opcode n
)
6708 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
6709 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
6711 return attribute_names
[0];
6714 /* Evaluate the 'POS attribute applied to ARG. */
6717 pos_atr (struct value
*arg
)
6719 struct type
*type
= value_type (arg
);
6721 if (!discrete_type_p (type
))
6722 error (_("'POS only defined on discrete types"));
6724 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6727 LONGEST v
= value_as_long (arg
);
6729 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6731 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6734 error (_("enumeration value is invalid: can't find 'POS"));
6737 return value_as_long (arg
);
6740 static struct value
*
6741 value_pos_atr (struct value
*arg
)
6743 return value_from_longest (builtin_type_int
, pos_atr (arg
));
6746 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6748 static struct value
*
6749 value_val_atr (struct type
*type
, struct value
*arg
)
6751 if (!discrete_type_p (type
))
6752 error (_("'VAL only defined on discrete types"));
6753 if (!integer_type_p (value_type (arg
)))
6754 error (_("'VAL requires integral argument"));
6756 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6758 long pos
= value_as_long (arg
);
6759 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6760 error (_("argument to 'VAL out of range"));
6761 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6764 return value_from_longest (type
, value_as_long (arg
));
6770 /* True if TYPE appears to be an Ada character type.
6771 [At the moment, this is true only for Character and Wide_Character;
6772 It is a heuristic test that could stand improvement]. */
6775 ada_is_character_type (struct type
*type
)
6777 const char *name
= ada_type_name (type
);
6780 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6781 || TYPE_CODE (type
) == TYPE_CODE_INT
6782 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6783 && (strcmp (name
, "character") == 0
6784 || strcmp (name
, "wide_character") == 0
6785 || strcmp (name
, "unsigned char") == 0);
6788 /* True if TYPE appears to be an Ada string type. */
6791 ada_is_string_type (struct type
*type
)
6793 type
= ada_check_typedef (type
);
6795 && TYPE_CODE (type
) != TYPE_CODE_PTR
6796 && (ada_is_simple_array_type (type
)
6797 || ada_is_array_descriptor_type (type
))
6798 && ada_array_arity (type
) == 1)
6800 struct type
*elttype
= ada_array_element_type (type
, 1);
6802 return ada_is_character_type (elttype
);
6809 /* True if TYPE is a struct type introduced by the compiler to force the
6810 alignment of a value. Such types have a single field with a
6811 distinctive name. */
6814 ada_is_aligner_type (struct type
*type
)
6816 type
= ada_check_typedef (type
);
6818 /* If we can find a parallel XVS type, then the XVS type should
6819 be used instead of this type. And hence, this is not an aligner
6821 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
6824 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6825 && TYPE_NFIELDS (type
) == 1
6826 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
6829 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6830 the parallel type. */
6833 ada_get_base_type (struct type
*raw_type
)
6835 struct type
*real_type_namer
;
6836 struct type
*raw_real_type
;
6838 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6841 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6842 if (real_type_namer
== NULL
6843 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6844 || TYPE_NFIELDS (real_type_namer
) != 1)
6847 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6848 if (raw_real_type
== NULL
)
6851 return raw_real_type
;
6854 /* The type of value designated by TYPE, with all aligners removed. */
6857 ada_aligned_type (struct type
*type
)
6859 if (ada_is_aligner_type (type
))
6860 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6862 return ada_get_base_type (type
);
6866 /* The address of the aligned value in an object at address VALADDR
6867 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6870 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
6872 if (ada_is_aligner_type (type
))
6873 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6875 TYPE_FIELD_BITPOS (type
,
6876 0) / TARGET_CHAR_BIT
);
6883 /* The printed representation of an enumeration literal with encoded
6884 name NAME. The value is good to the next call of ada_enum_name. */
6886 ada_enum_name (const char *name
)
6888 static char *result
;
6889 static size_t result_len
= 0;
6892 /* First, unqualify the enumeration name:
6893 1. Search for the last '.' character. If we find one, then skip
6894 all the preceeding characters, the unqualified name starts
6895 right after that dot.
6896 2. Otherwise, we may be debugging on a target where the compiler
6897 translates dots into "__". Search forward for double underscores,
6898 but stop searching when we hit an overloading suffix, which is
6899 of the form "__" followed by digits. */
6901 tmp
= strrchr (name
, '.');
6906 while ((tmp
= strstr (name
, "__")) != NULL
)
6908 if (isdigit (tmp
[2]))
6918 if (name
[1] == 'U' || name
[1] == 'W')
6920 if (sscanf (name
+ 2, "%x", &v
) != 1)
6926 GROW_VECT (result
, result_len
, 16);
6927 if (isascii (v
) && isprint (v
))
6928 sprintf (result
, "'%c'", v
);
6929 else if (name
[1] == 'U')
6930 sprintf (result
, "[\"%02x\"]", v
);
6932 sprintf (result
, "[\"%04x\"]", v
);
6938 tmp
= strstr (name
, "__");
6940 tmp
= strstr (name
, "$");
6943 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
6944 strncpy (result
, name
, tmp
- name
);
6945 result
[tmp
- name
] = '\0';
6953 static struct value
*
6954 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6957 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6958 (expect_type
, exp
, pos
, noside
);
6961 /* Evaluate the subexpression of EXP starting at *POS as for
6962 evaluate_type, updating *POS to point just past the evaluated
6965 static struct value
*
6966 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6968 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6969 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6972 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6975 static struct value
*
6976 unwrap_value (struct value
*val
)
6978 struct type
*type
= ada_check_typedef (value_type (val
));
6979 if (ada_is_aligner_type (type
))
6981 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6982 NULL
, "internal structure");
6983 struct type
*val_type
= ada_check_typedef (value_type (v
));
6984 if (ada_type_name (val_type
) == NULL
)
6985 TYPE_NAME (val_type
) = ada_type_name (type
);
6987 return unwrap_value (v
);
6991 struct type
*raw_real_type
=
6992 ada_check_typedef (ada_get_base_type (type
));
6994 if (type
== raw_real_type
)
6998 coerce_unspec_val_to_type
6999 (val
, ada_to_fixed_type (raw_real_type
, 0,
7000 VALUE_ADDRESS (val
) + value_offset (val
),
7005 static struct value
*
7006 cast_to_fixed (struct type
*type
, struct value
*arg
)
7010 if (type
== value_type (arg
))
7012 else if (ada_is_fixed_point_type (value_type (arg
)))
7013 val
= ada_float_to_fixed (type
,
7014 ada_fixed_to_float (value_type (arg
),
7015 value_as_long (arg
)));
7019 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
7020 val
= ada_float_to_fixed (type
, argd
);
7023 return value_from_longest (type
, val
);
7026 static struct value
*
7027 cast_from_fixed_to_double (struct value
*arg
)
7029 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7030 value_as_long (arg
));
7031 return value_from_double (builtin_type_double
, val
);
7034 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7035 return the converted value. */
7037 static struct value
*
7038 coerce_for_assign (struct type
*type
, struct value
*val
)
7040 struct type
*type2
= value_type (val
);
7044 type2
= ada_check_typedef (type2
);
7045 type
= ada_check_typedef (type
);
7047 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7048 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7050 val
= ada_value_ind (val
);
7051 type2
= value_type (val
);
7054 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7055 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7057 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7058 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7059 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7060 error (_("Incompatible types in assignment"));
7061 deprecated_set_value_type (val
, type
);
7066 static struct value
*
7067 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7070 struct type
*type1
, *type2
;
7073 arg1
= coerce_ref (arg1
);
7074 arg2
= coerce_ref (arg2
);
7075 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7076 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7078 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7079 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7080 return value_binop (arg1
, arg2
, op
);
7089 return value_binop (arg1
, arg2
, op
);
7092 v2
= value_as_long (arg2
);
7094 error (_("second operand of %s must not be zero."), op_string (op
));
7096 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7097 return value_binop (arg1
, arg2
, op
);
7099 v1
= value_as_long (arg1
);
7104 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7105 v
+= v
> 0 ? -1 : 1;
7113 /* Should not reach this point. */
7117 val
= allocate_value (type1
);
7118 store_unsigned_integer (value_contents_raw (val
),
7119 TYPE_LENGTH (value_type (val
)), v
);
7124 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7126 if (ada_is_direct_array_type (value_type (arg1
))
7127 || ada_is_direct_array_type (value_type (arg2
)))
7129 arg1
= ada_coerce_to_simple_array (arg1
);
7130 arg2
= ada_coerce_to_simple_array (arg2
);
7131 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
7132 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
7133 error (_("Attempt to compare array with non-array"));
7134 /* FIXME: The following works only for types whose
7135 representations use all bits (no padding or undefined bits)
7136 and do not have user-defined equality. */
7138 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
7139 && memcmp (value_contents (arg1
), value_contents (arg2
),
7140 TYPE_LENGTH (value_type (arg1
))) == 0;
7142 return value_equal (arg1
, arg2
);
7146 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
7147 int *pos
, enum noside noside
)
7150 int tem
, tem2
, tem3
;
7152 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
7155 struct value
**argvec
;
7159 op
= exp
->elts
[pc
].opcode
;
7166 unwrap_value (evaluate_subexp_standard
7167 (expect_type
, exp
, pos
, noside
));
7171 struct value
*result
;
7173 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
7174 /* The result type will have code OP_STRING, bashed there from
7175 OP_ARRAY. Bash it back. */
7176 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
7177 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
7183 type
= exp
->elts
[pc
+ 1].type
;
7184 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
7185 if (noside
== EVAL_SKIP
)
7187 if (type
!= ada_check_typedef (value_type (arg1
)))
7189 if (ada_is_fixed_point_type (type
))
7190 arg1
= cast_to_fixed (type
, arg1
);
7191 else if (ada_is_fixed_point_type (value_type (arg1
)))
7192 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
7193 else if (VALUE_LVAL (arg1
) == lval_memory
)
7195 /* This is in case of the really obscure (and undocumented,
7196 but apparently expected) case of (Foo) Bar.all, where Bar
7197 is an integer constant and Foo is a dynamic-sized type.
7198 If we don't do this, ARG1 will simply be relabeled with
7200 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7201 return value_zero (to_static_fixed_type (type
), not_lval
);
7203 ada_to_fixed_value_create
7204 (type
, VALUE_ADDRESS (arg1
) + value_offset (arg1
), 0);
7207 arg1
= value_cast (type
, arg1
);
7213 type
= exp
->elts
[pc
+ 1].type
;
7214 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
7217 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7218 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7219 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7221 if (ada_is_fixed_point_type (value_type (arg1
)))
7222 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
7223 else if (ada_is_fixed_point_type (value_type (arg2
)))
7225 (_("Fixed-point values must be assigned to fixed-point variables"));
7227 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
7228 return ada_value_assign (arg1
, arg2
);
7231 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7232 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7233 if (noside
== EVAL_SKIP
)
7235 if ((ada_is_fixed_point_type (value_type (arg1
))
7236 || ada_is_fixed_point_type (value_type (arg2
)))
7237 && value_type (arg1
) != value_type (arg2
))
7238 error (_("Operands of fixed-point addition must have the same type"));
7239 return value_cast (value_type (arg1
), value_add (arg1
, arg2
));
7242 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7243 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7244 if (noside
== EVAL_SKIP
)
7246 if ((ada_is_fixed_point_type (value_type (arg1
))
7247 || ada_is_fixed_point_type (value_type (arg2
)))
7248 && value_type (arg1
) != value_type (arg2
))
7249 error (_("Operands of fixed-point subtraction must have the same type"));
7250 return value_cast (value_type (arg1
), value_sub (arg1
, arg2
));
7254 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7255 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7256 if (noside
== EVAL_SKIP
)
7258 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7259 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7260 return value_zero (value_type (arg1
), not_lval
);
7263 if (ada_is_fixed_point_type (value_type (arg1
)))
7264 arg1
= cast_from_fixed_to_double (arg1
);
7265 if (ada_is_fixed_point_type (value_type (arg2
)))
7266 arg2
= cast_from_fixed_to_double (arg2
);
7267 return ada_value_binop (arg1
, arg2
, op
);
7272 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7273 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7274 if (noside
== EVAL_SKIP
)
7276 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7277 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7278 return value_zero (value_type (arg1
), not_lval
);
7280 return ada_value_binop (arg1
, arg2
, op
);
7283 case BINOP_NOTEQUAL
:
7284 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7285 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7286 if (noside
== EVAL_SKIP
)
7288 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7291 tem
= ada_value_equal (arg1
, arg2
);
7292 if (op
== BINOP_NOTEQUAL
)
7294 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
7297 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7298 if (noside
== EVAL_SKIP
)
7300 else if (ada_is_fixed_point_type (value_type (arg1
)))
7301 return value_cast (value_type (arg1
), value_neg (arg1
));
7303 return value_neg (arg1
);
7307 if (noside
== EVAL_SKIP
)
7312 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
7313 /* Only encountered when an unresolved symbol occurs in a
7314 context other than a function call, in which case, it is
7316 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7317 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
7318 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7322 (to_static_fixed_type
7323 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7329 unwrap_value (evaluate_subexp_standard
7330 (expect_type
, exp
, pos
, noside
));
7331 return ada_to_fixed_value (arg1
);
7337 /* Allocate arg vector, including space for the function to be
7338 called in argvec[0] and a terminating NULL. */
7339 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7341 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
7343 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
7344 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
7345 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7346 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
7349 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7350 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7353 if (noside
== EVAL_SKIP
)
7357 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
7358 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7359 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
7360 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
7361 && VALUE_LVAL (argvec
[0]) == lval_memory
))
7362 argvec
[0] = value_addr (argvec
[0]);
7364 type
= ada_check_typedef (value_type (argvec
[0]));
7365 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7367 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
7369 case TYPE_CODE_FUNC
:
7370 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7372 case TYPE_CODE_ARRAY
:
7374 case TYPE_CODE_STRUCT
:
7375 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7376 argvec
[0] = ada_value_ind (argvec
[0]);
7377 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7380 error (_("cannot subscript or call something of type `%s'"),
7381 ada_type_name (value_type (argvec
[0])));
7386 switch (TYPE_CODE (type
))
7388 case TYPE_CODE_FUNC
:
7389 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7390 return allocate_value (TYPE_TARGET_TYPE (type
));
7391 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7392 case TYPE_CODE_STRUCT
:
7396 arity
= ada_array_arity (type
);
7397 type
= ada_array_element_type (type
, nargs
);
7399 error (_("cannot subscript or call a record"));
7401 error (_("wrong number of subscripts; expecting %d"), arity
);
7402 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7403 return allocate_value (ada_aligned_type (type
));
7405 unwrap_value (ada_value_subscript
7406 (argvec
[0], nargs
, argvec
+ 1));
7408 case TYPE_CODE_ARRAY
:
7409 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7411 type
= ada_array_element_type (type
, nargs
);
7413 error (_("element type of array unknown"));
7415 return allocate_value (ada_aligned_type (type
));
7418 unwrap_value (ada_value_subscript
7419 (ada_coerce_to_simple_array (argvec
[0]),
7420 nargs
, argvec
+ 1));
7421 case TYPE_CODE_PTR
: /* Pointer to array */
7422 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7423 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7425 type
= ada_array_element_type (type
, nargs
);
7427 error (_("element type of array unknown"));
7429 return allocate_value (ada_aligned_type (type
));
7432 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7433 nargs
, argvec
+ 1));
7436 error (_("Attempt to index or call something other than an \
7437 array or function"));
7442 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7443 struct value
*low_bound_val
=
7444 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7445 struct value
*high_bound_val
=
7446 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7449 low_bound_val
= coerce_ref (low_bound_val
);
7450 high_bound_val
= coerce_ref (high_bound_val
);
7451 low_bound
= pos_atr (low_bound_val
);
7452 high_bound
= pos_atr (high_bound_val
);
7454 if (noside
== EVAL_SKIP
)
7457 /* If this is a reference to an aligner type, then remove all
7459 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7460 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
7461 TYPE_TARGET_TYPE (value_type (array
)) =
7462 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
7464 if (ada_is_packed_array_type (value_type (array
)))
7465 error (_("cannot slice a packed array"));
7467 /* If this is a reference to an array or an array lvalue,
7468 convert to a pointer. */
7469 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7470 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
7471 && VALUE_LVAL (array
) == lval_memory
))
7472 array
= value_addr (array
);
7474 if (noside
== EVAL_AVOID_SIDE_EFFECTS
7475 && ada_is_array_descriptor_type (ada_check_typedef
7476 (value_type (array
))))
7477 return empty_array (ada_type_of_array (array
, 0), low_bound
);
7479 array
= ada_coerce_to_simple_array_ptr (array
);
7481 /* If we have more than one level of pointer indirection,
7482 dereference the value until we get only one level. */
7483 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
7484 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
7486 array
= value_ind (array
);
7488 /* Make sure we really do have an array type before going further,
7489 to avoid a SEGV when trying to get the index type or the target
7490 type later down the road if the debug info generated by
7491 the compiler is incorrect or incomplete. */
7492 if (!ada_is_simple_array_type (value_type (array
)))
7493 error (_("cannot take slice of non-array"));
7495 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
7497 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7498 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
7502 struct type
*arr_type0
=
7503 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
7505 return ada_value_slice_ptr (array
, arr_type0
,
7510 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7512 else if (high_bound
< low_bound
)
7513 return empty_array (value_type (array
), low_bound
);
7515 return ada_value_slice (array
, (int) low_bound
, (int) high_bound
);
7520 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7521 type
= exp
->elts
[pc
+ 1].type
;
7523 if (noside
== EVAL_SKIP
)
7526 switch (TYPE_CODE (type
))
7529 lim_warning (_("Membership test incompletely implemented; \
7530 always returns true"));
7531 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
7533 case TYPE_CODE_RANGE
:
7534 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
7535 arg3
= value_from_longest (builtin_type_int
,
7536 TYPE_HIGH_BOUND (type
));
7538 value_from_longest (builtin_type_int
,
7539 (value_less (arg1
, arg3
)
7540 || value_equal (arg1
, arg3
))
7541 && (value_less (arg2
, arg1
)
7542 || value_equal (arg2
, arg1
)));
7545 case BINOP_IN_BOUNDS
:
7547 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7548 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7550 if (noside
== EVAL_SKIP
)
7553 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7554 return value_zero (builtin_type_int
, not_lval
);
7556 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7558 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
7559 error (_("invalid dimension number to 'range"));
7561 arg3
= ada_array_bound (arg2
, tem
, 1);
7562 arg2
= ada_array_bound (arg2
, tem
, 0);
7565 value_from_longest (builtin_type_int
,
7566 (value_less (arg1
, arg3
)
7567 || value_equal (arg1
, arg3
))
7568 && (value_less (arg2
, arg1
)
7569 || value_equal (arg2
, arg1
)));
7571 case TERNOP_IN_RANGE
:
7572 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7573 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7574 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7576 if (noside
== EVAL_SKIP
)
7580 value_from_longest (builtin_type_int
,
7581 (value_less (arg1
, arg3
)
7582 || value_equal (arg1
, arg3
))
7583 && (value_less (arg2
, arg1
)
7584 || value_equal (arg2
, arg1
)));
7590 struct type
*type_arg
;
7591 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
7593 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7595 type_arg
= exp
->elts
[pc
+ 2].type
;
7599 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7603 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
7604 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
7605 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
7608 if (noside
== EVAL_SKIP
)
7611 if (type_arg
== NULL
)
7613 arg1
= ada_coerce_ref (arg1
);
7615 if (ada_is_packed_array_type (value_type (arg1
)))
7616 arg1
= ada_coerce_to_simple_array (arg1
);
7618 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
7619 error (_("invalid dimension number to '%s"),
7620 ada_attribute_name (op
));
7622 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7624 type
= ada_index_type (value_type (arg1
), tem
);
7627 (_("attempt to take bound of something that is not an array"));
7628 return allocate_value (type
);
7633 default: /* Should never happen. */
7634 error (_("unexpected attribute encountered"));
7636 return ada_array_bound (arg1
, tem
, 0);
7638 return ada_array_bound (arg1
, tem
, 1);
7640 return ada_array_length (arg1
, tem
);
7643 else if (discrete_type_p (type_arg
))
7645 struct type
*range_type
;
7646 char *name
= ada_type_name (type_arg
);
7648 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
7650 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
7651 if (range_type
== NULL
)
7652 range_type
= type_arg
;
7656 error (_("unexpected attribute encountered"));
7658 return discrete_type_low_bound (range_type
);
7660 return discrete_type_high_bound (range_type
);
7662 error (_("the 'length attribute applies only to array types"));
7665 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
7666 error (_("unimplemented type attribute"));
7671 if (ada_is_packed_array_type (type_arg
))
7672 type_arg
= decode_packed_array_type (type_arg
);
7674 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
7675 error (_("invalid dimension number to '%s"),
7676 ada_attribute_name (op
));
7678 type
= ada_index_type (type_arg
, tem
);
7681 (_("attempt to take bound of something that is not an array"));
7682 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7683 return allocate_value (type
);
7688 error (_("unexpected attribute encountered"));
7690 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7691 return value_from_longest (type
, low
);
7693 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
7694 return value_from_longest (type
, high
);
7696 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7697 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
7698 return value_from_longest (type
, high
- low
+ 1);
7704 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7705 if (noside
== EVAL_SKIP
)
7708 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7709 return value_zero (ada_tag_type (arg1
), not_lval
);
7711 return ada_value_tag (arg1
);
7715 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7716 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7717 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7718 if (noside
== EVAL_SKIP
)
7720 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7721 return value_zero (value_type (arg1
), not_lval
);
7723 return value_binop (arg1
, arg2
,
7724 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
7726 case OP_ATR_MODULUS
:
7728 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
7729 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7731 if (noside
== EVAL_SKIP
)
7734 if (!ada_is_modular_type (type_arg
))
7735 error (_("'modulus must be applied to modular type"));
7737 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
7738 ada_modulus (type_arg
));
7743 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7744 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7745 if (noside
== EVAL_SKIP
)
7747 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7748 return value_zero (builtin_type_int
, not_lval
);
7750 return value_pos_atr (arg1
);
7753 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7754 if (noside
== EVAL_SKIP
)
7756 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7757 return value_zero (builtin_type_int
, not_lval
);
7759 return value_from_longest (builtin_type_int
,
7761 * TYPE_LENGTH (value_type (arg1
)));
7764 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7765 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7766 type
= exp
->elts
[pc
+ 2].type
;
7767 if (noside
== EVAL_SKIP
)
7769 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7770 return value_zero (type
, not_lval
);
7772 return value_val_atr (type
, arg1
);
7775 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7776 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7777 if (noside
== EVAL_SKIP
)
7779 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7780 return value_zero (value_type (arg1
), not_lval
);
7782 return value_binop (arg1
, arg2
, op
);
7785 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7786 if (noside
== EVAL_SKIP
)
7792 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7793 if (noside
== EVAL_SKIP
)
7795 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
7796 return value_neg (arg1
);
7801 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7802 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
7803 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7804 if (noside
== EVAL_SKIP
)
7806 type
= ada_check_typedef (value_type (arg1
));
7807 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7809 if (ada_is_array_descriptor_type (type
))
7810 /* GDB allows dereferencing GNAT array descriptors. */
7812 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7813 if (arrType
== NULL
)
7814 error (_("Attempt to dereference null array pointer."));
7815 return value_at_lazy (arrType
, 0);
7817 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7818 || TYPE_CODE (type
) == TYPE_CODE_REF
7819 /* In C you can dereference an array to get the 1st elt. */
7820 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7822 type
= to_static_fixed_type
7824 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
7826 return value_zero (type
, lval_memory
);
7828 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7829 /* GDB allows dereferencing an int. */
7830 return value_zero (builtin_type_int
, lval_memory
);
7832 error (_("Attempt to take contents of a non-pointer value."));
7834 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
7835 type
= ada_check_typedef (value_type (arg1
));
7837 if (ada_is_array_descriptor_type (type
))
7838 /* GDB allows dereferencing GNAT array descriptors. */
7839 return ada_coerce_to_simple_array (arg1
);
7841 return ada_value_ind (arg1
);
7843 case STRUCTOP_STRUCT
:
7844 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7845 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7846 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7847 if (noside
== EVAL_SKIP
)
7849 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7851 struct type
*type1
= value_type (arg1
);
7852 if (ada_is_tagged_type (type1
, 1))
7854 type
= ada_lookup_struct_elt_type (type1
,
7855 &exp
->elts
[pc
+ 2].string
,
7858 /* In this case, we assume that the field COULD exist
7859 in some extension of the type. Return an object of
7860 "type" void, which will match any formal
7861 (see ada_type_match). */
7862 return value_zero (builtin_type_void
, lval_memory
);
7866 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
7869 return value_zero (ada_aligned_type (type
), lval_memory
);
7873 ada_to_fixed_value (unwrap_value
7874 (ada_value_struct_elt
7875 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
7877 /* The value is not supposed to be used. This is here to make it
7878 easier to accommodate expressions that contain types. */
7880 if (noside
== EVAL_SKIP
)
7882 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7883 return allocate_value (builtin_type_void
);
7885 error (_("Attempt to use a type name as an expression"));
7889 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7895 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7896 type name that encodes the 'small and 'delta information.
7897 Otherwise, return NULL. */
7900 fixed_type_info (struct type
*type
)
7902 const char *name
= ada_type_name (type
);
7903 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7905 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7907 const char *tail
= strstr (name
, "___XF_");
7913 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7914 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7919 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7922 ada_is_fixed_point_type (struct type
*type
)
7924 return fixed_type_info (type
) != NULL
;
7927 /* Return non-zero iff TYPE represents a System.Address type. */
7930 ada_is_system_address_type (struct type
*type
)
7932 return (TYPE_NAME (type
)
7933 && strcmp (TYPE_NAME (type
), "system__address") == 0);
7936 /* Assuming that TYPE is the representation of an Ada fixed-point
7937 type, return its delta, or -1 if the type is malformed and the
7938 delta cannot be determined. */
7941 ada_delta (struct type
*type
)
7943 const char *encoding
= fixed_type_info (type
);
7946 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7949 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7952 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7953 factor ('SMALL value) associated with the type. */
7956 scaling_factor (struct type
*type
)
7958 const char *encoding
= fixed_type_info (type
);
7959 unsigned long num0
, den0
, num1
, den1
;
7962 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7967 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7969 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7973 /* Assuming that X is the representation of a value of fixed-point
7974 type TYPE, return its floating-point equivalent. */
7977 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7979 return (DOUBLEST
) x
*scaling_factor (type
);
7982 /* The representation of a fixed-point value of type TYPE
7983 corresponding to the value X. */
7986 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7988 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7992 /* VAX floating formats */
7994 /* Non-zero iff TYPE represents one of the special VAX floating-point
7998 ada_is_vax_floating_type (struct type
*type
)
8001 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
8004 && (TYPE_CODE (type
) == TYPE_CODE_INT
8005 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8006 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
8009 /* The type of special VAX floating-point type this is, assuming
8010 ada_is_vax_floating_point. */
8013 ada_vax_float_type_suffix (struct type
*type
)
8015 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
8018 /* A value representing the special debugging function that outputs
8019 VAX floating-point values of the type represented by TYPE. Assumes
8020 ada_is_vax_floating_type (TYPE). */
8023 ada_vax_float_print_function (struct type
*type
)
8025 switch (ada_vax_float_type_suffix (type
))
8028 return get_var_value ("DEBUG_STRING_F", 0);
8030 return get_var_value ("DEBUG_STRING_D", 0);
8032 return get_var_value ("DEBUG_STRING_G", 0);
8034 error (_("invalid VAX floating-point type"));
8041 /* Scan STR beginning at position K for a discriminant name, and
8042 return the value of that discriminant field of DVAL in *PX. If
8043 PNEW_K is not null, put the position of the character beyond the
8044 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8045 not alter *PX and *PNEW_K if unsuccessful. */
8048 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
8051 static char *bound_buffer
= NULL
;
8052 static size_t bound_buffer_len
= 0;
8055 struct value
*bound_val
;
8057 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
8060 pend
= strstr (str
+ k
, "__");
8064 k
+= strlen (bound
);
8068 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
8069 bound
= bound_buffer
;
8070 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
8071 bound
[pend
- (str
+ k
)] = '\0';
8075 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
8076 if (bound_val
== NULL
)
8079 *px
= value_as_long (bound_val
);
8085 /* Value of variable named NAME in the current environment. If
8086 no such variable found, then if ERR_MSG is null, returns 0, and
8087 otherwise causes an error with message ERR_MSG. */
8089 static struct value
*
8090 get_var_value (char *name
, char *err_msg
)
8092 struct ada_symbol_info
*syms
;
8095 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
8100 if (err_msg
== NULL
)
8103 error (("%s"), err_msg
);
8106 return value_of_variable (syms
[0].sym
, syms
[0].block
);
8109 /* Value of integer variable named NAME in the current environment. If
8110 no such variable found, returns 0, and sets *FLAG to 0. If
8111 successful, sets *FLAG to 1. */
8114 get_int_var_value (char *name
, int *flag
)
8116 struct value
*var_val
= get_var_value (name
, 0);
8128 return value_as_long (var_val
);
8133 /* Return a range type whose base type is that of the range type named
8134 NAME in the current environment, and whose bounds are calculated
8135 from NAME according to the GNAT range encoding conventions.
8136 Extract discriminant values, if needed, from DVAL. If a new type
8137 must be created, allocate in OBJFILE's space. The bounds
8138 information, in general, is encoded in NAME, the base type given in
8139 the named range type. */
8141 static struct type
*
8142 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
8144 struct type
*raw_type
= ada_find_any_type (name
);
8145 struct type
*base_type
;
8148 if (raw_type
== NULL
)
8149 base_type
= builtin_type_int
;
8150 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
8151 base_type
= TYPE_TARGET_TYPE (raw_type
);
8153 base_type
= raw_type
;
8155 subtype_info
= strstr (name
, "___XD");
8156 if (subtype_info
== NULL
)
8160 static char *name_buf
= NULL
;
8161 static size_t name_len
= 0;
8162 int prefix_len
= subtype_info
- name
;
8168 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
8169 strncpy (name_buf
, name
, prefix_len
);
8170 name_buf
[prefix_len
] = '\0';
8173 bounds_str
= strchr (subtype_info
, '_');
8176 if (*subtype_info
== 'L')
8178 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
8179 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
8181 if (bounds_str
[n
] == '_')
8183 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
8190 strcpy (name_buf
+ prefix_len
, "___L");
8191 L
= get_int_var_value (name_buf
, &ok
);
8194 lim_warning (_("Unknown lower bound, using 1."));
8199 if (*subtype_info
== 'U')
8201 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
8202 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
8208 strcpy (name_buf
+ prefix_len
, "___U");
8209 U
= get_int_var_value (name_buf
, &ok
);
8212 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
8217 if (objfile
== NULL
)
8218 objfile
= TYPE_OBJFILE (base_type
);
8219 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
8220 TYPE_NAME (type
) = name
;
8225 /* True iff NAME is the name of a range type. */
8228 ada_is_range_type_name (const char *name
)
8230 return (name
!= NULL
&& strstr (name
, "___XD"));
8236 /* True iff TYPE is an Ada modular type. */
8239 ada_is_modular_type (struct type
*type
)
8241 struct type
*subranged_type
= base_type (type
);
8243 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
8244 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
8245 && TYPE_UNSIGNED (subranged_type
));
8248 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8251 ada_modulus (struct type
* type
)
8253 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
8257 /* Information about operators given special treatment in functions
8259 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
8261 #define ADA_OPERATORS \
8262 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
8263 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
8264 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
8265 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
8266 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
8267 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
8268 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
8269 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
8270 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
8271 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
8272 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
8273 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
8274 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
8275 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
8276 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
8277 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
8280 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
8282 switch (exp
->elts
[pc
- 1].opcode
)
8285 operator_length_standard (exp
, pc
, oplenp
, argsp
);
8288 #define OP_DEFN(op, len, args, binop) \
8289 case op: *oplenp = len; *argsp = args; break;
8296 ada_op_name (enum exp_opcode opcode
)
8301 return op_name_standard (opcode
);
8302 #define OP_DEFN(op, len, args, binop) case op: return #op;
8308 /* As for operator_length, but assumes PC is pointing at the first
8309 element of the operator, and gives meaningful results only for the
8310 Ada-specific operators. */
8313 ada_forward_operator_length (struct expression
*exp
, int pc
,
8314 int *oplenp
, int *argsp
)
8316 switch (exp
->elts
[pc
].opcode
)
8319 *oplenp
= *argsp
= 0;
8321 #define OP_DEFN(op, len, args, binop) \
8322 case op: *oplenp = len; *argsp = args; break;
8329 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
8331 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
8336 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
8340 /* Ada attributes ('Foo). */
8347 case OP_ATR_MODULUS
:
8356 /* XXX: gdb_sprint_host_address, type_sprint */
8357 fprintf_filtered (stream
, _("Type @"));
8358 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
8359 fprintf_filtered (stream
, " (");
8360 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
8361 fprintf_filtered (stream
, ")");
8363 case BINOP_IN_BOUNDS
:
8364 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
8366 case TERNOP_IN_RANGE
:
8370 return dump_subexp_body_standard (exp
, stream
, elt
);
8374 for (i
= 0; i
< nargs
; i
+= 1)
8375 elt
= dump_subexp (exp
, stream
, elt
);
8380 /* The Ada extension of print_subexp (q.v.). */
8383 ada_print_subexp (struct expression
*exp
, int *pos
,
8384 struct ui_file
*stream
, enum precedence prec
)
8388 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
8390 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8395 print_subexp_standard (exp
, pos
, stream
, prec
);
8400 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
8403 case BINOP_IN_BOUNDS
:
8404 /* XXX: sprint_subexp */
8406 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8407 fputs_filtered (" in ", stream
);
8408 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8409 fputs_filtered ("'range", stream
);
8410 if (exp
->elts
[pc
+ 1].longconst
> 1)
8411 fprintf_filtered (stream
, "(%ld)",
8412 (long) exp
->elts
[pc
+ 1].longconst
);
8415 case TERNOP_IN_RANGE
:
8417 if (prec
>= PREC_EQUAL
)
8418 fputs_filtered ("(", stream
);
8419 /* XXX: sprint_subexp */
8420 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8421 fputs_filtered (" in ", stream
);
8422 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8423 fputs_filtered (" .. ", stream
);
8424 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8425 if (prec
>= PREC_EQUAL
)
8426 fputs_filtered (")", stream
);
8435 case OP_ATR_MODULUS
:
8441 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8443 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
8444 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
8448 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8449 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
8453 for (tem
= 1; tem
< nargs
; tem
+= 1)
8455 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
8456 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
8458 fputs_filtered (")", stream
);
8464 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
8465 fputs_filtered ("'(", stream
);
8466 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
8467 fputs_filtered (")", stream
);
8472 /* XXX: sprint_subexp */
8473 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8474 fputs_filtered (" in ", stream
);
8475 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
8480 /* Table mapping opcodes into strings for printing operators
8481 and precedences of the operators. */
8483 static const struct op_print ada_op_print_tab
[] = {
8484 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
8485 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
8486 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
8487 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
8488 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
8489 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
8490 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
8491 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
8492 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
8493 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
8494 {">", BINOP_GTR
, PREC_ORDER
, 0},
8495 {"<", BINOP_LESS
, PREC_ORDER
, 0},
8496 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
8497 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
8498 {"+", BINOP_ADD
, PREC_ADD
, 0},
8499 {"-", BINOP_SUB
, PREC_ADD
, 0},
8500 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8501 {"*", BINOP_MUL
, PREC_MUL
, 0},
8502 {"/", BINOP_DIV
, PREC_MUL
, 0},
8503 {"rem", BINOP_REM
, PREC_MUL
, 0},
8504 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8505 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8506 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8507 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8508 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8509 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8510 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8511 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8512 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
8513 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
8514 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
8518 /* Fundamental Ada Types */
8520 /* Create a fundamental Ada type using default reasonable for the current
8523 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8524 define fundamental types such as "int" or "double". Others (stabs or
8525 DWARF version 2, etc) do define fundamental types. For the formats which
8526 don't provide fundamental types, gdb can create such types using this
8529 FIXME: Some compilers distinguish explicitly signed integral types
8530 (signed short, signed int, signed long) from "regular" integral types
8531 (short, int, long) in the debugging information. There is some dis-
8532 agreement as to how useful this feature is. In particular, gcc does
8533 not support this. Also, only some debugging formats allow the
8534 distinction to be passed on to a debugger. For now, we always just
8535 use "short", "int", or "long" as the type name, for both the implicit
8536 and explicitly signed types. This also makes life easier for the
8537 gdb test suite since we don't have to account for the differences
8538 in output depending upon what the compiler and debugging format
8539 support. We will probably have to re-examine the issue when gdb
8540 starts taking it's fundamental type information directly from the
8541 debugging information supplied by the compiler. fnf@cygnus.com */
8543 static struct type
*
8544 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8546 struct type
*type
= NULL
;
8551 /* FIXME: For now, if we are asked to produce a type not in this
8552 language, create the equivalent of a C integer type with the
8553 name "<?type?>". When all the dust settles from the type
8554 reconstruction work, this should probably become an error. */
8555 type
= init_type (TYPE_CODE_INT
,
8556 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8557 0, "<?type?>", objfile
);
8558 warning (_("internal error: no Ada fundamental type %d"), typeid);
8561 type
= init_type (TYPE_CODE_VOID
,
8562 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8563 0, "void", objfile
);
8566 type
= init_type (TYPE_CODE_INT
,
8567 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8568 0, "character", objfile
);
8570 case FT_SIGNED_CHAR
:
8571 type
= init_type (TYPE_CODE_INT
,
8572 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8573 0, "signed char", objfile
);
8575 case FT_UNSIGNED_CHAR
:
8576 type
= init_type (TYPE_CODE_INT
,
8577 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8578 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8581 type
= init_type (TYPE_CODE_INT
,
8582 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8583 0, "short_integer", objfile
);
8585 case FT_SIGNED_SHORT
:
8586 type
= init_type (TYPE_CODE_INT
,
8587 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8588 0, "short_integer", objfile
);
8590 case FT_UNSIGNED_SHORT
:
8591 type
= init_type (TYPE_CODE_INT
,
8592 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8593 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8596 type
= init_type (TYPE_CODE_INT
,
8597 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8598 0, "integer", objfile
);
8600 case FT_SIGNED_INTEGER
:
8601 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/
8603 0, "integer", objfile
); /* FIXME -fnf */
8605 case FT_UNSIGNED_INTEGER
:
8606 type
= init_type (TYPE_CODE_INT
,
8607 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8608 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8611 type
= init_type (TYPE_CODE_INT
,
8612 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8613 0, "long_integer", objfile
);
8615 case FT_SIGNED_LONG
:
8616 type
= init_type (TYPE_CODE_INT
,
8617 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8618 0, "long_integer", objfile
);
8620 case FT_UNSIGNED_LONG
:
8621 type
= init_type (TYPE_CODE_INT
,
8622 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8623 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8626 type
= init_type (TYPE_CODE_INT
,
8627 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8628 0, "long_long_integer", objfile
);
8630 case FT_SIGNED_LONG_LONG
:
8631 type
= init_type (TYPE_CODE_INT
,
8632 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8633 0, "long_long_integer", objfile
);
8635 case FT_UNSIGNED_LONG_LONG
:
8636 type
= init_type (TYPE_CODE_INT
,
8637 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8638 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8641 type
= init_type (TYPE_CODE_FLT
,
8642 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8643 0, "float", objfile
);
8645 case FT_DBL_PREC_FLOAT
:
8646 type
= init_type (TYPE_CODE_FLT
,
8647 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8648 0, "long_float", objfile
);
8650 case FT_EXT_PREC_FLOAT
:
8651 type
= init_type (TYPE_CODE_FLT
,
8652 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8653 0, "long_long_float", objfile
);
8659 enum ada_primitive_types
{
8660 ada_primitive_type_int
,
8661 ada_primitive_type_long
,
8662 ada_primitive_type_short
,
8663 ada_primitive_type_char
,
8664 ada_primitive_type_float
,
8665 ada_primitive_type_double
,
8666 ada_primitive_type_void
,
8667 ada_primitive_type_long_long
,
8668 ada_primitive_type_long_double
,
8669 ada_primitive_type_natural
,
8670 ada_primitive_type_positive
,
8671 ada_primitive_type_system_address
,
8672 nr_ada_primitive_types
8676 ada_language_arch_info (struct gdbarch
*current_gdbarch
,
8677 struct language_arch_info
*lai
)
8679 const struct builtin_type
*builtin
= builtin_type (current_gdbarch
);
8680 lai
->primitive_type_vector
8681 = GDBARCH_OBSTACK_CALLOC (current_gdbarch
, nr_ada_primitive_types
+ 1,
8683 lai
->primitive_type_vector
[ada_primitive_type_int
] =
8684 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8685 0, "integer", (struct objfile
*) NULL
);
8686 lai
->primitive_type_vector
[ada_primitive_type_long
] =
8687 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8688 0, "long_integer", (struct objfile
*) NULL
);
8689 lai
->primitive_type_vector
[ada_primitive_type_short
] =
8690 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8691 0, "short_integer", (struct objfile
*) NULL
);
8692 lai
->string_char_type
=
8693 lai
->primitive_type_vector
[ada_primitive_type_char
] =
8694 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8695 0, "character", (struct objfile
*) NULL
);
8696 lai
->primitive_type_vector
[ada_primitive_type_float
] =
8697 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8698 0, "float", (struct objfile
*) NULL
);
8699 lai
->primitive_type_vector
[ada_primitive_type_double
] =
8700 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8701 0, "long_float", (struct objfile
*) NULL
);
8702 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
8703 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8704 0, "long_long_integer", (struct objfile
*) NULL
);
8705 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
8706 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8707 0, "long_long_float", (struct objfile
*) NULL
);
8708 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
8709 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8710 0, "natural", (struct objfile
*) NULL
);
8711 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
8712 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8713 0, "positive", (struct objfile
*) NULL
);
8714 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
8716 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
8717 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8718 (struct objfile
*) NULL
));
8719 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
8720 = "system__address";
8723 /* Language vector */
8725 /* Not really used, but needed in the ada_language_defn. */
8728 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8730 ada_emit_char (c
, stream
, quoter
, 1);
8736 warnings_issued
= 0;
8737 return ada_parse ();
8740 static const struct exp_descriptor ada_exp_descriptor
= {
8742 ada_operator_length
,
8744 ada_dump_subexp_body
,
8748 const struct language_defn ada_language_defn
= {
8749 "ada", /* Language name */
8754 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8755 that's not quite what this means. */
8757 &ada_exp_descriptor
,
8761 ada_printchar
, /* Print a character constant */
8762 ada_printstr
, /* Function to print string constant */
8763 emit_char
, /* Function to print single char (not used) */
8764 ada_create_fundamental_type
, /* Create fundamental type in this language */
8765 ada_print_type
, /* Print a type using appropriate syntax */
8766 ada_val_print
, /* Print a value using appropriate syntax */
8767 ada_value_print
, /* Print a top-level value */
8768 NULL
, /* Language specific skip_trampoline */
8769 NULL
, /* value_of_this */
8770 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
8771 basic_lookup_transparent_type
, /* lookup_transparent_type */
8772 ada_la_decode
, /* Language specific symbol demangler */
8773 NULL
, /* Language specific class_name_from_physname */
8774 ada_op_print_tab
, /* expression operators for printing */
8775 0, /* c-style arrays */
8776 1, /* String lower bound */
8778 ada_get_gdb_completer_word_break_characters
,
8779 ada_language_arch_info
,
8780 ada_print_array_index
,
8785 _initialize_ada_language (void)
8787 add_language (&ada_language_defn
);
8789 varsize_limit
= 65536;
8791 obstack_init (&symbol_list_obstack
);
8793 decoded_names_store
= htab_create_alloc
8794 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
8795 NULL
, xcalloc
, xfree
);