1 /* Ada language support routines for GDB, the GNU debugger. Copyright
2 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004.
3 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
24 #include "gdb_string.h"
28 #include "gdb_regex.h"
33 #include "expression.h"
34 #include "parser-defs.h"
40 #include "breakpoint.h"
43 #include "gdb_obstack.h"
45 #include "completer.h"
52 #include "dictionary.h"
54 #ifndef ADA_RETAIN_DOTS
55 #define ADA_RETAIN_DOTS 0
58 /* Define whether or not the C operator '/' truncates towards zero for
59 differently signed operands (truncation direction is undefined in C).
60 Copied from valarith.c. */
62 #ifndef TRUNCATION_TOWARDS_ZERO
63 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
67 static void extract_string (CORE_ADDR addr
, char *buf
);
69 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
71 static void modify_general_field (char *, LONGEST
, int, int);
73 static struct type
*desc_base_type (struct type
*);
75 static struct type
*desc_bounds_type (struct type
*);
77 static struct value
*desc_bounds (struct value
*);
79 static int fat_pntr_bounds_bitpos (struct type
*);
81 static int fat_pntr_bounds_bitsize (struct type
*);
83 static struct type
*desc_data_type (struct type
*);
85 static struct value
*desc_data (struct value
*);
87 static int fat_pntr_data_bitpos (struct type
*);
89 static int fat_pntr_data_bitsize (struct type
*);
91 static struct value
*desc_one_bound (struct value
*, int, int);
93 static int desc_bound_bitpos (struct type
*, int, int);
95 static int desc_bound_bitsize (struct type
*, int, int);
97 static struct type
*desc_index_type (struct type
*, int);
99 static int desc_arity (struct type
*);
101 static int ada_type_match (struct type
*, struct type
*, int);
103 static int ada_args_match (struct symbol
*, struct value
**, int);
105 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
107 static struct value
*convert_actual (struct value
*, struct type
*,
110 static struct value
*make_array_descriptor (struct type
*, struct value
*,
113 static void ada_add_block_symbols (struct obstack
*,
114 struct block
*, const char *,
115 domain_enum
, struct objfile
*,
116 struct symtab
*, int);
118 static int is_nonfunction (struct ada_symbol_info
*, int);
120 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
121 struct block
*, struct symtab
*);
123 static int num_defns_collected (struct obstack
*);
125 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
127 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
128 *, const char *, int,
131 static struct symtab
*symtab_for_sym (struct symbol
*);
133 static struct value
*resolve_subexp (struct expression
**, int *, int,
136 static void replace_operator_with_call (struct expression
**, int, int, int,
137 struct symbol
*, struct block
*);
139 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
141 static char *ada_op_name (enum exp_opcode
);
143 static const char *ada_decoded_op_name (enum exp_opcode
);
145 static int numeric_type_p (struct type
*);
147 static int integer_type_p (struct type
*);
149 static int scalar_type_p (struct type
*);
151 static int discrete_type_p (struct type
*);
153 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
156 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
159 static struct value
*evaluate_subexp_type (struct expression
*, int *);
161 static int is_dynamic_field (struct type
*, int);
163 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
164 CORE_ADDR
, struct value
*);
166 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
168 static struct type
*to_fixed_range_type (char *, struct value
*,
171 static struct type
*to_static_fixed_type (struct type
*);
173 static struct value
*unwrap_value (struct value
*);
175 static struct type
*packed_array_type (struct type
*, long *);
177 static struct type
*decode_packed_array_type (struct type
*);
179 static struct value
*decode_packed_array (struct value
*);
181 static struct value
*value_subscript_packed (struct value
*, int,
184 static struct value
*coerce_unspec_val_to_type (struct value
*,
187 static struct value
*get_var_value (char *, char *);
189 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
191 static int equiv_types (struct type
*, struct type
*);
193 static int is_name_suffix (const char *);
195 static int wild_match (const char *, int, const char *);
197 static struct value
*ada_coerce_ref (struct value
*);
199 static LONGEST
pos_atr (struct value
*);
201 static struct value
*value_pos_atr (struct value
*);
203 static struct value
*value_val_atr (struct type
*, struct value
*);
205 static struct symbol
*standard_lookup (const char *, const struct block
*,
208 static struct value
*ada_search_struct_field (char *, struct value
*, int,
211 static struct value
*ada_value_primitive_field (struct value
*, int, int,
214 static int find_struct_field (char *, struct type
*, int,
215 struct type
**, int *, int *, int *);
217 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
220 static struct value
*ada_to_fixed_value (struct value
*);
222 static int ada_resolve_function (struct ada_symbol_info
*, int,
223 struct value
**, int, const char *,
226 static struct value
*ada_coerce_to_simple_array (struct value
*);
228 static int ada_is_direct_array_type (struct type
*);
230 static void ada_language_arch_info (struct gdbarch
*,
231 struct language_arch_info
*);
233 static void check_size (const struct type
*);
237 /* Maximum-sized dynamic type. */
238 static unsigned int varsize_limit
;
240 /* FIXME: brobecker/2003-09-17: No longer a const because it is
241 returned by a function that does not return a const char *. */
242 static char *ada_completer_word_break_characters
=
244 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
246 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
249 /* The name of the symbol to use to get the name of the main subprogram. */
250 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
251 = "__gnat_ada_main_program_name";
253 /* The name of the runtime function called when an exception is raised. */
254 static const char raise_sym_name
[] = "__gnat_raise_nodefer_with_msg";
256 /* The name of the runtime function called when an unhandled exception
258 static const char raise_unhandled_sym_name
[] = "__gnat_unhandled_exception";
260 /* The name of the runtime function called when an assert failure is
262 static const char raise_assert_sym_name
[] =
263 "system__assertions__raise_assert_failure";
265 /* When GDB stops on an unhandled exception, GDB will go up the stack until
266 if finds a frame corresponding to this function, in order to extract the
267 name of the exception that has been raised from one of the parameters. */
268 static const char process_raise_exception_name
[] =
269 "ada__exceptions__process_raise_exception";
271 /* A string that reflects the longest exception expression rewrite,
272 aside from the exception name. */
273 static const char longest_exception_template
[] =
274 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
276 /* Limit on the number of warnings to raise per expression evaluation. */
277 static int warning_limit
= 2;
279 /* Number of warning messages issued; reset to 0 by cleanups after
280 expression evaluation. */
281 static int warnings_issued
= 0;
283 static const char *known_runtime_file_name_patterns
[] = {
284 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
287 static const char *known_auxiliary_function_name_patterns
[] = {
288 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
291 /* Space for allocating results of ada_lookup_symbol_list. */
292 static struct obstack symbol_list_obstack
;
298 ada_get_gdb_completer_word_break_characters (void)
300 return ada_completer_word_break_characters
;
303 /* Read the string located at ADDR from the inferior and store the
307 extract_string (CORE_ADDR addr
, char *buf
)
311 /* Loop, reading one byte at a time, until we reach the '\000'
312 end-of-string marker. */
315 target_read_memory (addr
+ char_index
* sizeof (char),
316 buf
+ char_index
* sizeof (char), sizeof (char));
319 while (buf
[char_index
- 1] != '\000');
322 /* Assuming VECT points to an array of *SIZE objects of size
323 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
324 updating *SIZE as necessary and returning the (new) array. */
327 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
329 if (*size
< min_size
)
332 if (*size
< min_size
)
334 vect
= xrealloc (vect
, *size
* element_size
);
339 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
340 suffix of FIELD_NAME beginning "___". */
343 field_name_match (const char *field_name
, const char *target
)
345 int len
= strlen (target
);
347 (strncmp (field_name
, target
, len
) == 0
348 && (field_name
[len
] == '\0'
349 || (strncmp (field_name
+ len
, "___", 3) == 0
350 && strcmp (field_name
+ strlen (field_name
) - 6,
355 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
356 FIELD_NAME, and return its index. This function also handles fields
357 whose name have ___ suffixes because the compiler sometimes alters
358 their name by adding such a suffix to represent fields with certain
359 constraints. If the field could not be found, return a negative
360 number if MAYBE_MISSING is set. Otherwise raise an error. */
363 ada_get_field_index (const struct type
*type
, const char *field_name
,
367 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
368 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
372 error (_("Unable to find field %s in struct %s. Aborting"),
373 field_name
, TYPE_NAME (type
));
378 /* The length of the prefix of NAME prior to any "___" suffix. */
381 ada_name_prefix_len (const char *name
)
387 const char *p
= strstr (name
, "___");
389 return strlen (name
);
395 /* Return non-zero if SUFFIX is a suffix of STR.
396 Return zero if STR is null. */
399 is_suffix (const char *str
, const char *suffix
)
405 len2
= strlen (suffix
);
406 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
409 /* Create a value of type TYPE whose contents come from VALADDR, if it
410 is non-null, and whose memory address (in the inferior) is
414 value_from_contents_and_address (struct type
*type
, char *valaddr
,
417 struct value
*v
= allocate_value (type
);
421 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
422 VALUE_ADDRESS (v
) = address
;
424 VALUE_LVAL (v
) = lval_memory
;
428 /* The contents of value VAL, treated as a value of type TYPE. The
429 result is an lval in memory if VAL is. */
431 static struct value
*
432 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
434 type
= ada_check_typedef (type
);
435 if (value_type (val
) == type
)
439 struct value
*result
;
441 /* Make sure that the object size is not unreasonable before
442 trying to allocate some memory for it. */
445 result
= allocate_value (type
);
446 VALUE_LVAL (result
) = VALUE_LVAL (val
);
447 result
->bitsize
= value_bitsize (val
);
448 result
->bitpos
= value_bitpos (val
);
449 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + value_offset (val
);
451 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
452 VALUE_LAZY (result
) = 1;
454 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
),
461 cond_offset_host (char *valaddr
, long offset
)
466 return valaddr
+ offset
;
470 cond_offset_target (CORE_ADDR address
, long offset
)
475 return address
+ offset
;
478 /* Issue a warning (as for the definition of warning in utils.c, but
479 with exactly one argument rather than ...), unless the limit on the
480 number of warnings has passed during the evaluation of the current
483 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
484 provided by "complaint". */
485 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
488 lim_warning (const char *format
, ...)
491 va_start (args
, format
);
493 warnings_issued
+= 1;
494 if (warnings_issued
<= warning_limit
)
495 vwarning (format
, args
);
500 /* Issue an error if the size of an object of type T is unreasonable,
501 i.e. if it would be a bad idea to allocate a value of this type in
505 check_size (const struct type
*type
)
507 if (TYPE_LENGTH (type
) > varsize_limit
)
508 error (_("object size is larger than varsize-limit"));
512 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
513 gdbtypes.h, but some of the necessary definitions in that file
514 seem to have gone missing. */
516 /* Maximum value of a SIZE-byte signed integer type. */
518 max_of_size (int size
)
520 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
521 return top_bit
| (top_bit
- 1);
524 /* Minimum value of a SIZE-byte signed integer type. */
526 min_of_size (int size
)
528 return -max_of_size (size
) - 1;
531 /* Maximum value of a SIZE-byte unsigned integer type. */
533 umax_of_size (int size
)
535 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
536 return top_bit
| (top_bit
- 1);
539 /* Maximum value of integral type T, as a signed quantity. */
541 max_of_type (struct type
*t
)
543 if (TYPE_UNSIGNED (t
))
544 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
546 return max_of_size (TYPE_LENGTH (t
));
549 /* Minimum value of integral type T, as a signed quantity. */
551 min_of_type (struct type
*t
)
553 if (TYPE_UNSIGNED (t
))
556 return min_of_size (TYPE_LENGTH (t
));
559 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
560 static struct value
*
561 discrete_type_high_bound (struct type
*type
)
563 switch (TYPE_CODE (type
))
565 case TYPE_CODE_RANGE
:
566 return value_from_longest (TYPE_TARGET_TYPE (type
),
567 TYPE_HIGH_BOUND (type
));
570 value_from_longest (type
,
571 TYPE_FIELD_BITPOS (type
,
572 TYPE_NFIELDS (type
) - 1));
574 return value_from_longest (type
, max_of_type (type
));
576 error (_("Unexpected type in discrete_type_high_bound."));
580 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
581 static struct value
*
582 discrete_type_low_bound (struct type
*type
)
584 switch (TYPE_CODE (type
))
586 case TYPE_CODE_RANGE
:
587 return value_from_longest (TYPE_TARGET_TYPE (type
),
588 TYPE_LOW_BOUND (type
));
590 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
592 return value_from_longest (type
, min_of_type (type
));
594 error (_("Unexpected type in discrete_type_low_bound."));
598 /* The identity on non-range types. For range types, the underlying
599 non-range scalar type. */
602 base_type (struct type
*type
)
604 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
606 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
608 type
= TYPE_TARGET_TYPE (type
);
614 /* Language Selection */
616 /* If the main program is in Ada, return language_ada, otherwise return LANG
617 (the main program is in Ada iif the adainit symbol is found).
619 MAIN_PST is not used. */
622 ada_update_initial_language (enum language lang
,
623 struct partial_symtab
*main_pst
)
625 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
626 (struct objfile
*) NULL
) != NULL
)
632 /* If the main procedure is written in Ada, then return its name.
633 The result is good until the next call. Return NULL if the main
634 procedure doesn't appear to be in Ada. */
639 struct minimal_symbol
*msym
;
640 CORE_ADDR main_program_name_addr
;
641 static char main_program_name
[1024];
643 /* For Ada, the name of the main procedure is stored in a specific
644 string constant, generated by the binder. Look for that symbol,
645 extract its address, and then read that string. If we didn't find
646 that string, then most probably the main procedure is not written
648 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
652 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
653 if (main_program_name_addr
== 0)
654 error (_("Invalid address for Ada main program name."));
656 extract_string (main_program_name_addr
, main_program_name
);
657 return main_program_name
;
660 /* The main procedure doesn't seem to be in Ada. */
666 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
669 const struct ada_opname_map ada_opname_table
[] = {
670 {"Oadd", "\"+\"", BINOP_ADD
},
671 {"Osubtract", "\"-\"", BINOP_SUB
},
672 {"Omultiply", "\"*\"", BINOP_MUL
},
673 {"Odivide", "\"/\"", BINOP_DIV
},
674 {"Omod", "\"mod\"", BINOP_MOD
},
675 {"Orem", "\"rem\"", BINOP_REM
},
676 {"Oexpon", "\"**\"", BINOP_EXP
},
677 {"Olt", "\"<\"", BINOP_LESS
},
678 {"Ole", "\"<=\"", BINOP_LEQ
},
679 {"Ogt", "\">\"", BINOP_GTR
},
680 {"Oge", "\">=\"", BINOP_GEQ
},
681 {"Oeq", "\"=\"", BINOP_EQUAL
},
682 {"One", "\"/=\"", BINOP_NOTEQUAL
},
683 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
684 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
685 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
686 {"Oconcat", "\"&\"", BINOP_CONCAT
},
687 {"Oabs", "\"abs\"", UNOP_ABS
},
688 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
689 {"Oadd", "\"+\"", UNOP_PLUS
},
690 {"Osubtract", "\"-\"", UNOP_NEG
},
694 /* Return non-zero if STR should be suppressed in info listings. */
697 is_suppressed_name (const char *str
)
699 if (strncmp (str
, "_ada_", 5) == 0)
701 if (str
[0] == '_' || str
[0] == '\000')
706 const char *suffix
= strstr (str
, "___");
707 if (suffix
!= NULL
&& suffix
[3] != 'X')
710 suffix
= str
+ strlen (str
);
711 for (p
= suffix
- 1; p
!= str
; p
-= 1)
715 if (p
[0] == 'X' && p
[-1] != '_')
719 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
720 if (strncmp (ada_opname_table
[i
].encoded
, p
,
721 strlen (ada_opname_table
[i
].encoded
)) == 0)
730 /* The "encoded" form of DECODED, according to GNAT conventions.
731 The result is valid until the next call to ada_encode. */
734 ada_encode (const char *decoded
)
736 static char *encoding_buffer
= NULL
;
737 static size_t encoding_buffer_size
= 0;
744 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
745 2 * strlen (decoded
) + 10);
748 for (p
= decoded
; *p
!= '\0'; p
+= 1)
750 if (!ADA_RETAIN_DOTS
&& *p
== '.')
752 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
757 const struct ada_opname_map
*mapping
;
759 for (mapping
= ada_opname_table
;
760 mapping
->encoded
!= NULL
761 && strncmp (mapping
->decoded
, p
,
762 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
764 if (mapping
->encoded
== NULL
)
765 error (_("invalid Ada operator name: %s"), p
);
766 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
767 k
+= strlen (mapping
->encoded
);
772 encoding_buffer
[k
] = *p
;
777 encoding_buffer
[k
] = '\0';
778 return encoding_buffer
;
781 /* Return NAME folded to lower case, or, if surrounded by single
782 quotes, unfolded, but with the quotes stripped away. Result good
786 ada_fold_name (const char *name
)
788 static char *fold_buffer
= NULL
;
789 static size_t fold_buffer_size
= 0;
791 int len
= strlen (name
);
792 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
796 strncpy (fold_buffer
, name
+ 1, len
- 2);
797 fold_buffer
[len
- 2] = '\000';
802 for (i
= 0; i
<= len
; i
+= 1)
803 fold_buffer
[i
] = tolower (name
[i
]);
810 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
811 These are suffixes introduced by GNAT5 to nested subprogram
812 names, and do not serve any purpose for the debugger.
813 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
814 2. Convert other instances of embedded "__" to `.'.
815 3. Discard leading _ada_.
816 4. Convert operator names to the appropriate quoted symbols.
817 5. Remove everything after first ___ if it is followed by
819 6. Replace TK__ with __, and a trailing B or TKB with nothing.
820 7. Put symbols that should be suppressed in <...> brackets.
821 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
823 The resulting string is valid until the next call of ada_decode.
824 If the string is unchanged by demangling, the original string pointer
828 ada_decode (const char *encoded
)
835 static char *decoding_buffer
= NULL
;
836 static size_t decoding_buffer_size
= 0;
838 if (strncmp (encoded
, "_ada_", 5) == 0)
841 if (encoded
[0] == '_' || encoded
[0] == '<')
844 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
845 len0
= strlen (encoded
);
846 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
849 while (i
> 0 && isdigit (encoded
[i
]))
851 if (i
>= 0 && encoded
[i
] == '.')
853 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
857 /* Remove the ___X.* suffix if present. Do not forget to verify that
858 the suffix is located before the current "end" of ENCODED. We want
859 to avoid re-matching parts of ENCODED that have previously been
860 marked as discarded (by decrementing LEN0). */
861 p
= strstr (encoded
, "___");
862 if (p
!= NULL
&& p
- encoded
< len0
- 3)
870 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
873 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
876 /* Make decoded big enough for possible expansion by operator name. */
877 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
878 decoded
= decoding_buffer
;
880 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
883 while ((i
>= 0 && isdigit (encoded
[i
]))
884 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
886 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
888 else if (encoded
[i
] == '$')
892 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
893 decoded
[j
] = encoded
[i
];
898 if (at_start_name
&& encoded
[i
] == 'O')
901 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
903 int op_len
= strlen (ada_opname_table
[k
].encoded
);
904 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
906 && !isalnum (encoded
[i
+ op_len
]))
908 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
911 j
+= strlen (ada_opname_table
[k
].decoded
);
915 if (ada_opname_table
[k
].encoded
!= NULL
)
920 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
922 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
926 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
930 else if (!ADA_RETAIN_DOTS
931 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
940 decoded
[j
] = encoded
[i
];
947 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
948 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
951 if (strcmp (decoded
, encoded
) == 0)
957 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
958 decoded
= decoding_buffer
;
959 if (encoded
[0] == '<')
960 strcpy (decoded
, encoded
);
962 sprintf (decoded
, "<%s>", encoded
);
967 /* Table for keeping permanent unique copies of decoded names. Once
968 allocated, names in this table are never released. While this is a
969 storage leak, it should not be significant unless there are massive
970 changes in the set of decoded names in successive versions of a
971 symbol table loaded during a single session. */
972 static struct htab
*decoded_names_store
;
974 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
975 in the language-specific part of GSYMBOL, if it has not been
976 previously computed. Tries to save the decoded name in the same
977 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
978 in any case, the decoded symbol has a lifetime at least that of
980 The GSYMBOL parameter is "mutable" in the C++ sense: logically
981 const, but nevertheless modified to a semantically equivalent form
982 when a decoded name is cached in it.
986 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
989 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
990 if (*resultp
== NULL
)
992 const char *decoded
= ada_decode (gsymbol
->name
);
993 if (gsymbol
->bfd_section
!= NULL
)
995 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
998 struct objfile
*objf
;
1001 if (obfd
== objf
->obfd
)
1003 *resultp
= obsavestring (decoded
, strlen (decoded
),
1004 &objf
->objfile_obstack
);
1010 /* Sometimes, we can't find a corresponding objfile, in which
1011 case, we put the result on the heap. Since we only decode
1012 when needed, we hope this usually does not cause a
1013 significant memory leak (FIXME). */
1014 if (*resultp
== NULL
)
1016 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1019 *slot
= xstrdup (decoded
);
1028 ada_la_decode (const char *encoded
, int options
)
1030 return xstrdup (ada_decode (encoded
));
1033 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1034 suffixes that encode debugging information or leading _ada_ on
1035 SYM_NAME (see is_name_suffix commentary for the debugging
1036 information that is ignored). If WILD, then NAME need only match a
1037 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1038 either argument is NULL. */
1041 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1043 if (sym_name
== NULL
|| name
== NULL
)
1046 return wild_match (name
, strlen (name
), sym_name
);
1049 int len_name
= strlen (name
);
1050 return (strncmp (sym_name
, name
, len_name
) == 0
1051 && is_name_suffix (sym_name
+ len_name
))
1052 || (strncmp (sym_name
, "_ada_", 5) == 0
1053 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1054 && is_name_suffix (sym_name
+ len_name
+ 5));
1058 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1059 suppressed in info listings. */
1062 ada_suppress_symbol_printing (struct symbol
*sym
)
1064 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1067 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1073 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1075 static char *bound_name
[] = {
1076 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1077 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1080 /* Maximum number of array dimensions we are prepared to handle. */
1082 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1084 /* Like modify_field, but allows bitpos > wordlength. */
1087 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1089 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1093 /* The desc_* routines return primitive portions of array descriptors
1096 /* The descriptor or array type, if any, indicated by TYPE; removes
1097 level of indirection, if needed. */
1099 static struct type
*
1100 desc_base_type (struct type
*type
)
1104 type
= ada_check_typedef (type
);
1106 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1107 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1108 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1113 /* True iff TYPE indicates a "thin" array pointer type. */
1116 is_thin_pntr (struct type
*type
)
1119 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1120 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1123 /* The descriptor type for thin pointer type TYPE. */
1125 static struct type
*
1126 thin_descriptor_type (struct type
*type
)
1128 struct type
*base_type
= desc_base_type (type
);
1129 if (base_type
== NULL
)
1131 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1135 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1136 if (alt_type
== NULL
)
1143 /* A pointer to the array data for thin-pointer value VAL. */
1145 static struct value
*
1146 thin_data_pntr (struct value
*val
)
1148 struct type
*type
= value_type (val
);
1149 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1150 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1153 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1154 VALUE_ADDRESS (val
) + value_offset (val
));
1157 /* True iff TYPE indicates a "thick" array pointer type. */
1160 is_thick_pntr (struct type
*type
)
1162 type
= desc_base_type (type
);
1163 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1164 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1167 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1168 pointer to one, the type of its bounds data; otherwise, NULL. */
1170 static struct type
*
1171 desc_bounds_type (struct type
*type
)
1175 type
= desc_base_type (type
);
1179 else if (is_thin_pntr (type
))
1181 type
= thin_descriptor_type (type
);
1184 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1186 return ada_check_typedef (r
);
1188 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1190 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1192 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1197 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1198 one, a pointer to its bounds data. Otherwise NULL. */
1200 static struct value
*
1201 desc_bounds (struct value
*arr
)
1203 struct type
*type
= ada_check_typedef (value_type (arr
));
1204 if (is_thin_pntr (type
))
1206 struct type
*bounds_type
=
1207 desc_bounds_type (thin_descriptor_type (type
));
1210 if (desc_bounds_type
== NULL
)
1211 error (_("Bad GNAT array descriptor"));
1213 /* NOTE: The following calculation is not really kosher, but
1214 since desc_type is an XVE-encoded type (and shouldn't be),
1215 the correct calculation is a real pain. FIXME (and fix GCC). */
1216 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1217 addr
= value_as_long (arr
);
1219 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1222 value_from_longest (lookup_pointer_type (bounds_type
),
1223 addr
- TYPE_LENGTH (bounds_type
));
1226 else if (is_thick_pntr (type
))
1227 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1228 _("Bad GNAT array descriptor"));
1233 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1234 position of the field containing the address of the bounds data. */
1237 fat_pntr_bounds_bitpos (struct type
*type
)
1239 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1242 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1243 size of the field containing the address of the bounds data. */
1246 fat_pntr_bounds_bitsize (struct type
*type
)
1248 type
= desc_base_type (type
);
1250 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1251 return TYPE_FIELD_BITSIZE (type
, 1);
1253 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1256 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1257 pointer to one, the type of its array data (a
1258 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1259 ada_type_of_array to get an array type with bounds data. */
1261 static struct type
*
1262 desc_data_type (struct type
*type
)
1264 type
= desc_base_type (type
);
1266 /* NOTE: The following is bogus; see comment in desc_bounds. */
1267 if (is_thin_pntr (type
))
1268 return lookup_pointer_type
1269 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1270 else if (is_thick_pntr (type
))
1271 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1276 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1279 static struct value
*
1280 desc_data (struct value
*arr
)
1282 struct type
*type
= value_type (arr
);
1283 if (is_thin_pntr (type
))
1284 return thin_data_pntr (arr
);
1285 else if (is_thick_pntr (type
))
1286 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1287 _("Bad GNAT array descriptor"));
1293 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1294 position of the field containing the address of the data. */
1297 fat_pntr_data_bitpos (struct type
*type
)
1299 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1302 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1303 size of the field containing the address of the data. */
1306 fat_pntr_data_bitsize (struct type
*type
)
1308 type
= desc_base_type (type
);
1310 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1311 return TYPE_FIELD_BITSIZE (type
, 0);
1313 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1316 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1317 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1318 bound, if WHICH is 1. The first bound is I=1. */
1320 static struct value
*
1321 desc_one_bound (struct value
*bounds
, int i
, int which
)
1323 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1324 _("Bad GNAT array descriptor bounds"));
1327 /* If BOUNDS is an array-bounds structure type, return the bit position
1328 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1329 bound, if WHICH is 1. The first bound is I=1. */
1332 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1334 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1337 /* If BOUNDS is an array-bounds structure type, return the bit field size
1338 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1339 bound, if WHICH is 1. The first bound is I=1. */
1342 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1344 type
= desc_base_type (type
);
1346 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1347 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1349 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1352 /* If TYPE is the type of an array-bounds structure, the type of its
1353 Ith bound (numbering from 1). Otherwise, NULL. */
1355 static struct type
*
1356 desc_index_type (struct type
*type
, int i
)
1358 type
= desc_base_type (type
);
1360 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1361 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1366 /* The number of index positions in the array-bounds type TYPE.
1367 Return 0 if TYPE is NULL. */
1370 desc_arity (struct type
*type
)
1372 type
= desc_base_type (type
);
1375 return TYPE_NFIELDS (type
) / 2;
1379 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1380 an array descriptor type (representing an unconstrained array
1384 ada_is_direct_array_type (struct type
*type
)
1388 type
= ada_check_typedef (type
);
1389 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1390 || ada_is_array_descriptor_type (type
));
1393 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1396 ada_is_simple_array_type (struct type
*type
)
1400 type
= ada_check_typedef (type
);
1401 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1402 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1403 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1406 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1409 ada_is_array_descriptor_type (struct type
*type
)
1411 struct type
*data_type
= desc_data_type (type
);
1415 type
= ada_check_typedef (type
);
1418 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1419 && TYPE_TARGET_TYPE (data_type
) != NULL
1420 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1421 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1422 && desc_arity (desc_bounds_type (type
)) > 0;
1425 /* Non-zero iff type is a partially mal-formed GNAT array
1426 descriptor. FIXME: This is to compensate for some problems with
1427 debugging output from GNAT. Re-examine periodically to see if it
1431 ada_is_bogus_array_descriptor (struct type
*type
)
1435 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1436 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1437 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1438 && !ada_is_array_descriptor_type (type
);
1442 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1443 (fat pointer) returns the type of the array data described---specifically,
1444 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1445 in from the descriptor; otherwise, they are left unspecified. If
1446 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1447 returns NULL. The result is simply the type of ARR if ARR is not
1450 ada_type_of_array (struct value
*arr
, int bounds
)
1452 if (ada_is_packed_array_type (value_type (arr
)))
1453 return decode_packed_array_type (value_type (arr
));
1455 if (!ada_is_array_descriptor_type (value_type (arr
)))
1456 return value_type (arr
);
1460 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1463 struct type
*elt_type
;
1465 struct value
*descriptor
;
1466 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1468 elt_type
= ada_array_element_type (value_type (arr
), -1);
1469 arity
= ada_array_arity (value_type (arr
));
1471 if (elt_type
== NULL
|| arity
== 0)
1472 return ada_check_typedef (value_type (arr
));
1474 descriptor
= desc_bounds (arr
);
1475 if (value_as_long (descriptor
) == 0)
1479 struct type
*range_type
= alloc_type (objf
);
1480 struct type
*array_type
= alloc_type (objf
);
1481 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1482 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1485 create_range_type (range_type
, value_type (low
),
1486 (int) value_as_long (low
),
1487 (int) value_as_long (high
));
1488 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1491 return lookup_pointer_type (elt_type
);
1495 /* If ARR does not represent an array, returns ARR unchanged.
1496 Otherwise, returns either a standard GDB array with bounds set
1497 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1498 GDB array. Returns NULL if ARR is a null fat pointer. */
1501 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1503 if (ada_is_array_descriptor_type (value_type (arr
)))
1505 struct type
*arrType
= ada_type_of_array (arr
, 1);
1506 if (arrType
== NULL
)
1508 return value_cast (arrType
, value_copy (desc_data (arr
)));
1510 else if (ada_is_packed_array_type (value_type (arr
)))
1511 return decode_packed_array (arr
);
1516 /* If ARR does not represent an array, returns ARR unchanged.
1517 Otherwise, returns a standard GDB array describing ARR (which may
1518 be ARR itself if it already is in the proper form). */
1520 static struct value
*
1521 ada_coerce_to_simple_array (struct value
*arr
)
1523 if (ada_is_array_descriptor_type (value_type (arr
)))
1525 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1527 error (_("Bounds unavailable for null array pointer."));
1528 return value_ind (arrVal
);
1530 else if (ada_is_packed_array_type (value_type (arr
)))
1531 return decode_packed_array (arr
);
1536 /* If TYPE represents a GNAT array type, return it translated to an
1537 ordinary GDB array type (possibly with BITSIZE fields indicating
1538 packing). For other types, is the identity. */
1541 ada_coerce_to_simple_array_type (struct type
*type
)
1543 struct value
*mark
= value_mark ();
1544 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1545 struct type
*result
;
1547 result
= ada_type_of_array (dummy
, 0);
1548 value_free_to_mark (mark
);
1552 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1555 ada_is_packed_array_type (struct type
*type
)
1559 type
= desc_base_type (type
);
1560 type
= ada_check_typedef (type
);
1562 ada_type_name (type
) != NULL
1563 && strstr (ada_type_name (type
), "___XP") != NULL
;
1566 /* Given that TYPE is a standard GDB array type with all bounds filled
1567 in, and that the element size of its ultimate scalar constituents
1568 (that is, either its elements, or, if it is an array of arrays, its
1569 elements' elements, etc.) is *ELT_BITS, return an identical type,
1570 but with the bit sizes of its elements (and those of any
1571 constituent arrays) recorded in the BITSIZE components of its
1572 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1575 static struct type
*
1576 packed_array_type (struct type
*type
, long *elt_bits
)
1578 struct type
*new_elt_type
;
1579 struct type
*new_type
;
1580 LONGEST low_bound
, high_bound
;
1582 type
= ada_check_typedef (type
);
1583 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1586 new_type
= alloc_type (TYPE_OBJFILE (type
));
1587 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1589 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1590 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1591 TYPE_NAME (new_type
) = ada_type_name (type
);
1593 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1594 &low_bound
, &high_bound
) < 0)
1595 low_bound
= high_bound
= 0;
1596 if (high_bound
< low_bound
)
1597 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1600 *elt_bits
*= (high_bound
- low_bound
+ 1);
1601 TYPE_LENGTH (new_type
) =
1602 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1605 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1609 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1611 static struct type
*
1612 decode_packed_array_type (struct type
*type
)
1615 struct block
**blocks
;
1616 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
1617 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1618 char *tail
= strstr (raw_name
, "___XP");
1619 struct type
*shadow_type
;
1623 type
= desc_base_type (type
);
1625 memcpy (name
, raw_name
, tail
- raw_name
);
1626 name
[tail
- raw_name
] = '\000';
1628 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1629 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1631 lim_warning (_("could not find bounds information on packed array"));
1634 shadow_type
= SYMBOL_TYPE (sym
);
1636 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1638 lim_warning (_("could not understand bounds information on packed array"));
1642 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1645 (_("could not understand bit size information on packed array"));
1649 return packed_array_type (shadow_type
, &bits
);
1652 /* Given that ARR is a struct value *indicating a GNAT packed array,
1653 returns a simple array that denotes that array. Its type is a
1654 standard GDB array type except that the BITSIZEs of the array
1655 target types are set to the number of bits in each element, and the
1656 type length is set appropriately. */
1658 static struct value
*
1659 decode_packed_array (struct value
*arr
)
1663 arr
= ada_coerce_ref (arr
);
1664 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1665 arr
= ada_value_ind (arr
);
1667 type
= decode_packed_array_type (value_type (arr
));
1670 error (_("can't unpack array"));
1674 if (BITS_BIG_ENDIAN
&& ada_is_modular_type (value_type (arr
)))
1676 /* This is a (right-justified) modular type representing a packed
1677 array with no wrapper. In order to interpret the value through
1678 the (left-justified) packed array type we just built, we must
1679 first left-justify it. */
1680 int bit_size
, bit_pos
;
1683 mod
= ada_modulus (value_type (arr
)) - 1;
1690 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1691 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1692 bit_pos
/ HOST_CHAR_BIT
,
1693 bit_pos
% HOST_CHAR_BIT
,
1698 return coerce_unspec_val_to_type (arr
, type
);
1702 /* The value of the element of packed array ARR at the ARITY indices
1703 given in IND. ARR must be a simple array. */
1705 static struct value
*
1706 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1709 int bits
, elt_off
, bit_off
;
1710 long elt_total_bit_offset
;
1711 struct type
*elt_type
;
1715 elt_total_bit_offset
= 0;
1716 elt_type
= ada_check_typedef (value_type (arr
));
1717 for (i
= 0; i
< arity
; i
+= 1)
1719 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1720 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1722 (_("attempt to do packed indexing of something other than a packed array"));
1725 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1726 LONGEST lowerbound
, upperbound
;
1729 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1731 lim_warning (_("don't know bounds of array"));
1732 lowerbound
= upperbound
= 0;
1735 idx
= value_as_long (value_pos_atr (ind
[i
]));
1736 if (idx
< lowerbound
|| idx
> upperbound
)
1737 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1738 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1739 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1740 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1743 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1744 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1746 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1748 if (VALUE_LVAL (arr
) == lval_internalvar
)
1749 VALUE_LVAL (v
) = lval_internalvar_component
;
1751 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1755 /* Non-zero iff TYPE includes negative integer values. */
1758 has_negatives (struct type
*type
)
1760 switch (TYPE_CODE (type
))
1765 return !TYPE_UNSIGNED (type
);
1766 case TYPE_CODE_RANGE
:
1767 return TYPE_LOW_BOUND (type
) < 0;
1772 /* Create a new value of type TYPE from the contents of OBJ starting
1773 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1774 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1775 assigning through the result will set the field fetched from.
1776 VALADDR is ignored unless OBJ is NULL, in which case,
1777 VALADDR+OFFSET must address the start of storage containing the
1778 packed value. The value returned in this case is never an lval.
1779 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1782 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1783 int bit_offset
, int bit_size
,
1787 int src
, /* Index into the source area */
1788 targ
, /* Index into the target area */
1789 srcBitsLeft
, /* Number of source bits left to move */
1790 nsrc
, ntarg
, /* Number of source and target bytes */
1791 unusedLS
, /* Number of bits in next significant
1792 byte of source that are unused */
1793 accumSize
; /* Number of meaningful bits in accum */
1794 unsigned char *bytes
; /* First byte containing data to unpack */
1795 unsigned char *unpacked
;
1796 unsigned long accum
; /* Staging area for bits being transferred */
1798 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1799 /* Transmit bytes from least to most significant; delta is the direction
1800 the indices move. */
1801 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1803 type
= ada_check_typedef (type
);
1807 v
= allocate_value (type
);
1808 bytes
= (unsigned char *) (valaddr
+ offset
);
1810 else if (VALUE_LAZY (obj
))
1813 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
1814 bytes
= (unsigned char *) alloca (len
);
1815 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1819 v
= allocate_value (type
);
1820 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1825 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1826 if (VALUE_LVAL (obj
) == lval_internalvar
)
1827 VALUE_LVAL (v
) = lval_internalvar_component
;
1828 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
;
1829 v
->bitpos
= bit_offset
+ value_bitpos (obj
);
1830 v
->bitsize
= bit_size
;
1831 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
1833 VALUE_ADDRESS (v
) += 1;
1834 v
->bitpos
-= HOST_CHAR_BIT
;
1838 v
->bitsize
= bit_size
;
1839 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1841 srcBitsLeft
= bit_size
;
1843 ntarg
= TYPE_LENGTH (type
);
1847 memset (unpacked
, 0, TYPE_LENGTH (type
));
1850 else if (BITS_BIG_ENDIAN
)
1853 if (has_negatives (type
)
1854 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1858 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1861 switch (TYPE_CODE (type
))
1863 case TYPE_CODE_ARRAY
:
1864 case TYPE_CODE_UNION
:
1865 case TYPE_CODE_STRUCT
:
1866 /* Non-scalar values must be aligned at a byte boundary... */
1868 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1869 /* ... And are placed at the beginning (most-significant) bytes
1875 targ
= TYPE_LENGTH (type
) - 1;
1881 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1884 unusedLS
= bit_offset
;
1887 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1894 /* Mask for removing bits of the next source byte that are not
1895 part of the value. */
1896 unsigned int unusedMSMask
=
1897 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1899 /* Sign-extend bits for this byte. */
1900 unsigned int signMask
= sign
& ~unusedMSMask
;
1902 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1903 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1904 if (accumSize
>= HOST_CHAR_BIT
)
1906 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1907 accumSize
-= HOST_CHAR_BIT
;
1908 accum
>>= HOST_CHAR_BIT
;
1912 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1919 accum
|= sign
<< accumSize
;
1920 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1921 accumSize
-= HOST_CHAR_BIT
;
1922 accum
>>= HOST_CHAR_BIT
;
1930 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1931 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1934 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
1936 unsigned int accum
, mask
;
1937 int accum_bits
, chunk_size
;
1939 target
+= targ_offset
/ HOST_CHAR_BIT
;
1940 targ_offset
%= HOST_CHAR_BIT
;
1941 source
+= src_offset
/ HOST_CHAR_BIT
;
1942 src_offset
%= HOST_CHAR_BIT
;
1943 if (BITS_BIG_ENDIAN
)
1945 accum
= (unsigned char) *source
;
1947 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1952 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1953 accum_bits
+= HOST_CHAR_BIT
;
1955 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1958 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1959 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1962 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1964 accum_bits
-= chunk_size
;
1971 accum
= (unsigned char) *source
>> src_offset
;
1973 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1977 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1978 accum_bits
+= HOST_CHAR_BIT
;
1980 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1983 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1984 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1986 accum_bits
-= chunk_size
;
1987 accum
>>= chunk_size
;
1995 /* Store the contents of FROMVAL into the location of TOVAL.
1996 Return a new value with the location of TOVAL and contents of
1997 FROMVAL. Handles assignment into packed fields that have
1998 floating-point or non-scalar types. */
2000 static struct value
*
2001 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2003 struct type
*type
= value_type (toval
);
2004 int bits
= value_bitsize (toval
);
2006 if (!toval
->modifiable
)
2007 error (_("Left operand of assignment is not a modifiable lvalue."));
2009 toval
= coerce_ref (toval
);
2011 if (VALUE_LVAL (toval
) == lval_memory
2013 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2014 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2016 int len
= (value_bitpos (toval
)
2017 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2018 char *buffer
= (char *) alloca (len
);
2021 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2022 fromval
= value_cast (type
, fromval
);
2024 read_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
, len
);
2025 if (BITS_BIG_ENDIAN
)
2026 move_bits (buffer
, value_bitpos (toval
),
2027 VALUE_CONTENTS (fromval
),
2028 TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
-
2031 move_bits (buffer
, value_bitpos (toval
), VALUE_CONTENTS (fromval
),
2033 write_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
,
2036 val
= value_copy (toval
);
2037 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
2038 TYPE_LENGTH (type
));
2044 return value_assign (toval
, fromval
);
2048 /* The value of the element of array ARR at the ARITY indices given in IND.
2049 ARR may be either a simple array, GNAT array descriptor, or pointer
2053 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2057 struct type
*elt_type
;
2059 elt
= ada_coerce_to_simple_array (arr
);
2061 elt_type
= ada_check_typedef (value_type (elt
));
2062 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2063 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2064 return value_subscript_packed (elt
, arity
, ind
);
2066 for (k
= 0; k
< arity
; k
+= 1)
2068 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2069 error (_("too many subscripts (%d expected)"), k
);
2070 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2075 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2076 value of the element of *ARR at the ARITY indices given in
2077 IND. Does not read the entire array into memory. */
2080 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2085 for (k
= 0; k
< arity
; k
+= 1)
2090 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2091 error (_("too many subscripts (%d expected)"), k
);
2092 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2094 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2095 idx
= value_pos_atr (ind
[k
]);
2097 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2098 arr
= value_add (arr
, idx
);
2099 type
= TYPE_TARGET_TYPE (type
);
2102 return value_ind (arr
);
2105 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2106 actual type of ARRAY_PTR is ignored), returns a reference to
2107 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2108 bound of this array is LOW, as per Ada rules. */
2109 static struct value
*
2110 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2113 CORE_ADDR base
= value_as_address (array_ptr
)
2114 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2115 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2116 struct type
*index_type
=
2117 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2119 struct type
*slice_type
=
2120 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2121 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2125 static struct value
*
2126 ada_value_slice (struct value
*array
, int low
, int high
)
2128 struct type
*type
= value_type (array
);
2129 struct type
*index_type
=
2130 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2131 struct type
*slice_type
=
2132 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2133 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2136 /* If type is a record type in the form of a standard GNAT array
2137 descriptor, returns the number of dimensions for type. If arr is a
2138 simple array, returns the number of "array of"s that prefix its
2139 type designation. Otherwise, returns 0. */
2142 ada_array_arity (struct type
*type
)
2149 type
= desc_base_type (type
);
2152 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2153 return desc_arity (desc_bounds_type (type
));
2155 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2158 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2164 /* If TYPE is a record type in the form of a standard GNAT array
2165 descriptor or a simple array type, returns the element type for
2166 TYPE after indexing by NINDICES indices, or by all indices if
2167 NINDICES is -1. Otherwise, returns NULL. */
2170 ada_array_element_type (struct type
*type
, int nindices
)
2172 type
= desc_base_type (type
);
2174 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2177 struct type
*p_array_type
;
2179 p_array_type
= desc_data_type (type
);
2181 k
= ada_array_arity (type
);
2185 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2186 if (nindices
>= 0 && k
> nindices
)
2188 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2189 while (k
> 0 && p_array_type
!= NULL
)
2191 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2194 return p_array_type
;
2196 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2198 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2200 type
= TYPE_TARGET_TYPE (type
);
2209 /* The type of nth index in arrays of given type (n numbering from 1).
2210 Does not examine memory. */
2213 ada_index_type (struct type
*type
, int n
)
2215 struct type
*result_type
;
2217 type
= desc_base_type (type
);
2219 if (n
> ada_array_arity (type
))
2222 if (ada_is_simple_array_type (type
))
2226 for (i
= 1; i
< n
; i
+= 1)
2227 type
= TYPE_TARGET_TYPE (type
);
2228 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2229 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2230 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2231 perhaps stabsread.c would make more sense. */
2232 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2233 result_type
= builtin_type_int
;
2238 return desc_index_type (desc_bounds_type (type
), n
);
2241 /* Given that arr is an array type, returns the lower bound of the
2242 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2243 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2244 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2245 bounds type. It works for other arrays with bounds supplied by
2246 run-time quantities other than discriminants. */
2249 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2250 struct type
** typep
)
2253 struct type
*index_type_desc
;
2255 if (ada_is_packed_array_type (arr_type
))
2256 arr_type
= decode_packed_array_type (arr_type
);
2258 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2261 *typep
= builtin_type_int
;
2262 return (LONGEST
) - which
;
2265 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2266 type
= TYPE_TARGET_TYPE (arr_type
);
2270 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2271 if (index_type_desc
== NULL
)
2273 struct type
*range_type
;
2274 struct type
*index_type
;
2278 type
= TYPE_TARGET_TYPE (type
);
2282 range_type
= TYPE_INDEX_TYPE (type
);
2283 index_type
= TYPE_TARGET_TYPE (range_type
);
2284 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2285 index_type
= builtin_type_long
;
2287 *typep
= index_type
;
2289 (LONGEST
) (which
== 0
2290 ? TYPE_LOW_BOUND (range_type
)
2291 : TYPE_HIGH_BOUND (range_type
));
2295 struct type
*index_type
=
2296 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2297 NULL
, TYPE_OBJFILE (arr_type
));
2299 *typep
= TYPE_TARGET_TYPE (index_type
);
2301 (LONGEST
) (which
== 0
2302 ? TYPE_LOW_BOUND (index_type
)
2303 : TYPE_HIGH_BOUND (index_type
));
2307 /* Given that arr is an array value, returns the lower bound of the
2308 nth index (numbering from 1) if which is 0, and the upper bound if
2309 which is 1. This routine will also work for arrays with bounds
2310 supplied by run-time quantities other than discriminants. */
2313 ada_array_bound (struct value
*arr
, int n
, int which
)
2315 struct type
*arr_type
= value_type (arr
);
2317 if (ada_is_packed_array_type (arr_type
))
2318 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2319 else if (ada_is_simple_array_type (arr_type
))
2322 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2323 return value_from_longest (type
, v
);
2326 return desc_one_bound (desc_bounds (arr
), n
, which
);
2329 /* Given that arr is an array value, returns the length of the
2330 nth index. This routine will also work for arrays with bounds
2331 supplied by run-time quantities other than discriminants.
2332 Does not work for arrays indexed by enumeration types with representation
2333 clauses at the moment. */
2336 ada_array_length (struct value
*arr
, int n
)
2338 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2340 if (ada_is_packed_array_type (arr_type
))
2341 return ada_array_length (decode_packed_array (arr
), n
);
2343 if (ada_is_simple_array_type (arr_type
))
2347 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2348 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2349 return value_from_longest (type
, v
);
2353 value_from_longest (builtin_type_int
,
2354 value_as_long (desc_one_bound (desc_bounds (arr
),
2356 - value_as_long (desc_one_bound (desc_bounds (arr
),
2360 /* An empty array whose type is that of ARR_TYPE (an array type),
2361 with bounds LOW to LOW-1. */
2363 static struct value
*
2364 empty_array (struct type
*arr_type
, int low
)
2366 struct type
*index_type
=
2367 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2369 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2370 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2374 /* Name resolution */
2376 /* The "decoded" name for the user-definable Ada operator corresponding
2380 ada_decoded_op_name (enum exp_opcode op
)
2384 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2386 if (ada_opname_table
[i
].op
== op
)
2387 return ada_opname_table
[i
].decoded
;
2389 error (_("Could not find operator name for opcode"));
2393 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2394 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2395 undefined namespace) and converts operators that are
2396 user-defined into appropriate function calls. If CONTEXT_TYPE is
2397 non-null, it provides a preferred result type [at the moment, only
2398 type void has any effect---causing procedures to be preferred over
2399 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2400 return type is preferred. May change (expand) *EXP. */
2403 resolve (struct expression
**expp
, int void_context_p
)
2407 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2410 /* Resolve the operator of the subexpression beginning at
2411 position *POS of *EXPP. "Resolving" consists of replacing
2412 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2413 with their resolutions, replacing built-in operators with
2414 function calls to user-defined operators, where appropriate, and,
2415 when DEPROCEDURE_P is non-zero, converting function-valued variables
2416 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2417 are as in ada_resolve, above. */
2419 static struct value
*
2420 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2421 struct type
*context_type
)
2425 struct expression
*exp
; /* Convenience: == *expp. */
2426 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2427 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2428 int nargs
; /* Number of operands. */
2434 /* Pass one: resolve operands, saving their types and updating *pos. */
2438 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2439 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2444 resolve_subexp (expp
, pos
, 0, NULL
);
2446 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2451 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2456 resolve_subexp (expp
, pos
, 0, NULL
);
2459 case OP_ATR_MODULUS
:
2489 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2491 resolve_subexp (expp
, pos
, 1, NULL
);
2493 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2511 case BINOP_LOGICAL_AND
:
2512 case BINOP_LOGICAL_OR
:
2513 case BINOP_BITWISE_AND
:
2514 case BINOP_BITWISE_IOR
:
2515 case BINOP_BITWISE_XOR
:
2518 case BINOP_NOTEQUAL
:
2525 case BINOP_SUBSCRIPT
:
2533 case UNOP_LOGICAL_NOT
:
2550 case OP_INTERNALVAR
:
2559 case STRUCTOP_STRUCT
:
2560 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2566 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2571 case TERNOP_IN_RANGE
:
2576 case BINOP_IN_BOUNDS
:
2582 error (_("Unexpected operator during name resolution"));
2585 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2586 for (i
= 0; i
< nargs
; i
+= 1)
2587 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2591 /* Pass two: perform any resolution on principal operator. */
2598 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2600 struct ada_symbol_info
*candidates
;
2604 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2605 (exp
->elts
[pc
+ 2].symbol
),
2606 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2609 if (n_candidates
> 1)
2611 /* Types tend to get re-introduced locally, so if there
2612 are any local symbols that are not types, first filter
2615 for (j
= 0; j
< n_candidates
; j
+= 1)
2616 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2622 case LOC_REGPARM_ADDR
:
2626 case LOC_BASEREG_ARG
:
2628 case LOC_COMPUTED_ARG
:
2634 if (j
< n_candidates
)
2637 while (j
< n_candidates
)
2639 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2641 candidates
[j
] = candidates
[n_candidates
- 1];
2650 if (n_candidates
== 0)
2651 error (_("No definition found for %s"),
2652 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2653 else if (n_candidates
== 1)
2655 else if (deprocedure_p
2656 && !is_nonfunction (candidates
, n_candidates
))
2658 i
= ada_resolve_function
2659 (candidates
, n_candidates
, NULL
, 0,
2660 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2663 error (_("Could not find a match for %s"),
2664 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2668 printf_filtered (_("Multiple matches for %s\n"),
2669 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2670 user_select_syms (candidates
, n_candidates
, 1);
2674 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2675 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2676 if (innermost_block
== NULL
2677 || contained_in (candidates
[i
].block
, innermost_block
))
2678 innermost_block
= candidates
[i
].block
;
2682 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2685 replace_operator_with_call (expp
, pc
, 0, 0,
2686 exp
->elts
[pc
+ 2].symbol
,
2687 exp
->elts
[pc
+ 1].block
);
2694 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2695 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2697 struct ada_symbol_info
*candidates
;
2701 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2702 (exp
->elts
[pc
+ 5].symbol
),
2703 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2705 if (n_candidates
== 1)
2709 i
= ada_resolve_function
2710 (candidates
, n_candidates
,
2712 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2715 error (_("Could not find a match for %s"),
2716 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2719 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2720 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2721 if (innermost_block
== NULL
2722 || contained_in (candidates
[i
].block
, innermost_block
))
2723 innermost_block
= candidates
[i
].block
;
2734 case BINOP_BITWISE_AND
:
2735 case BINOP_BITWISE_IOR
:
2736 case BINOP_BITWISE_XOR
:
2738 case BINOP_NOTEQUAL
:
2746 case UNOP_LOGICAL_NOT
:
2748 if (possible_user_operator_p (op
, argvec
))
2750 struct ada_symbol_info
*candidates
;
2754 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2755 (struct block
*) NULL
, VAR_DOMAIN
,
2757 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2758 ada_decoded_op_name (op
), NULL
);
2762 replace_operator_with_call (expp
, pc
, nargs
, 1,
2763 candidates
[i
].sym
, candidates
[i
].block
);
2773 return evaluate_subexp_type (exp
, pos
);
2776 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2777 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2778 a non-pointer. A type of 'void' (which is never a valid expression type)
2779 by convention matches anything. */
2780 /* The term "match" here is rather loose. The match is heuristic and
2781 liberal. FIXME: TOO liberal, in fact. */
2784 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2786 ftype
= ada_check_typedef (ftype
);
2787 atype
= ada_check_typedef (atype
);
2789 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2790 ftype
= TYPE_TARGET_TYPE (ftype
);
2791 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2792 atype
= TYPE_TARGET_TYPE (atype
);
2794 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2795 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2798 switch (TYPE_CODE (ftype
))
2803 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2804 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2805 TYPE_TARGET_TYPE (atype
), 0);
2808 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2810 case TYPE_CODE_ENUM
:
2811 case TYPE_CODE_RANGE
:
2812 switch (TYPE_CODE (atype
))
2815 case TYPE_CODE_ENUM
:
2816 case TYPE_CODE_RANGE
:
2822 case TYPE_CODE_ARRAY
:
2823 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2824 || ada_is_array_descriptor_type (atype
));
2826 case TYPE_CODE_STRUCT
:
2827 if (ada_is_array_descriptor_type (ftype
))
2828 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2829 || ada_is_array_descriptor_type (atype
));
2831 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2832 && !ada_is_array_descriptor_type (atype
));
2834 case TYPE_CODE_UNION
:
2836 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2840 /* Return non-zero if the formals of FUNC "sufficiently match" the
2841 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2842 may also be an enumeral, in which case it is treated as a 0-
2843 argument function. */
2846 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2849 struct type
*func_type
= SYMBOL_TYPE (func
);
2851 if (SYMBOL_CLASS (func
) == LOC_CONST
2852 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2853 return (n_actuals
== 0);
2854 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2857 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2860 for (i
= 0; i
< n_actuals
; i
+= 1)
2862 if (actuals
[i
] == NULL
)
2866 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2867 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
2869 if (!ada_type_match (ftype
, atype
, 1))
2876 /* False iff function type FUNC_TYPE definitely does not produce a value
2877 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2878 FUNC_TYPE is not a valid function type with a non-null return type
2879 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2882 return_match (struct type
*func_type
, struct type
*context_type
)
2884 struct type
*return_type
;
2886 if (func_type
== NULL
)
2889 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2890 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2892 return_type
= base_type (func_type
);
2893 if (return_type
== NULL
)
2896 context_type
= base_type (context_type
);
2898 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2899 return context_type
== NULL
|| return_type
== context_type
;
2900 else if (context_type
== NULL
)
2901 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2903 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2907 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
2908 function (if any) that matches the types of the NARGS arguments in
2909 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2910 that returns that type, then eliminate matches that don't. If
2911 CONTEXT_TYPE is void and there is at least one match that does not
2912 return void, eliminate all matches that do.
2914 Asks the user if there is more than one match remaining. Returns -1
2915 if there is no such symbol or none is selected. NAME is used
2916 solely for messages. May re-arrange and modify SYMS in
2917 the process; the index returned is for the modified vector. */
2920 ada_resolve_function (struct ada_symbol_info syms
[],
2921 int nsyms
, struct value
**args
, int nargs
,
2922 const char *name
, struct type
*context_type
)
2925 int m
; /* Number of hits */
2926 struct type
*fallback
;
2927 struct type
*return_type
;
2929 return_type
= context_type
;
2930 if (context_type
== NULL
)
2931 fallback
= builtin_type_void
;
2938 for (k
= 0; k
< nsyms
; k
+= 1)
2940 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
2942 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
2943 && return_match (type
, return_type
))
2949 if (m
> 0 || return_type
== fallback
)
2952 return_type
= fallback
;
2959 printf_filtered (_("Multiple matches for %s\n"), name
);
2960 user_select_syms (syms
, m
, 1);
2966 /* Returns true (non-zero) iff decoded name N0 should appear before N1
2967 in a listing of choices during disambiguation (see sort_choices, below).
2968 The idea is that overloadings of a subprogram name from the
2969 same package should sort in their source order. We settle for ordering
2970 such symbols by their trailing number (__N or $N). */
2973 encoded_ordered_before (char *N0
, char *N1
)
2977 else if (N0
== NULL
)
2982 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2984 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2986 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2987 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2991 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2994 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2996 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
2997 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
2999 return (strcmp (N0
, N1
) < 0);
3003 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3007 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3010 for (i
= 1; i
< nsyms
; i
+= 1)
3012 struct ada_symbol_info sym
= syms
[i
];
3015 for (j
= i
- 1; j
>= 0; j
-= 1)
3017 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3018 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3020 syms
[j
+ 1] = syms
[j
];
3026 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3027 by asking the user (if necessary), returning the number selected,
3028 and setting the first elements of SYMS items. Error if no symbols
3031 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3032 to be re-integrated one of these days. */
3035 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3038 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3040 int first_choice
= (max_results
== 1) ? 1 : 2;
3042 if (max_results
< 1)
3043 error (_("Request to select 0 symbols!"));
3047 printf_unfiltered (_("[0] cancel\n"));
3048 if (max_results
> 1)
3049 printf_unfiltered (_("[1] all\n"));
3051 sort_choices (syms
, nsyms
);
3053 for (i
= 0; i
< nsyms
; i
+= 1)
3055 if (syms
[i
].sym
== NULL
)
3058 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3060 struct symtab_and_line sal
=
3061 find_function_start_sal (syms
[i
].sym
, 1);
3062 if (sal
.symtab
== NULL
)
3063 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3065 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3068 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3069 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3070 sal
.symtab
->filename
, sal
.line
);
3076 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3077 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3078 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3079 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3081 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3082 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3084 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3085 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3086 else if (is_enumeral
3087 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3089 printf_unfiltered ("[%d] ", i
+ first_choice
);
3090 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3092 printf_unfiltered (_("'(%s) (enumeral)\n"),
3093 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3095 else if (symtab
!= NULL
)
3096 printf_unfiltered (is_enumeral
3097 ? _("[%d] %s in %s (enumeral)\n")
3098 : _("[%d] %s at %s:?\n"),
3100 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3103 printf_unfiltered (is_enumeral
3104 ? _("[%d] %s (enumeral)\n")
3105 : _("[%d] %s at ?\n"),
3107 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3111 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3114 for (i
= 0; i
< n_chosen
; i
+= 1)
3115 syms
[i
] = syms
[chosen
[i
]];
3120 /* Read and validate a set of numeric choices from the user in the
3121 range 0 .. N_CHOICES-1. Place the results in increasing
3122 order in CHOICES[0 .. N-1], and return N.
3124 The user types choices as a sequence of numbers on one line
3125 separated by blanks, encoding them as follows:
3127 + A choice of 0 means to cancel the selection, throwing an error.
3128 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3129 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3131 The user is not allowed to choose more than MAX_RESULTS values.
3133 ANNOTATION_SUFFIX, if present, is used to annotate the input
3134 prompts (for use with the -f switch). */
3137 get_selections (int *choices
, int n_choices
, int max_results
,
3138 int is_all_choice
, char *annotation_suffix
)
3143 int first_choice
= is_all_choice
? 2 : 1;
3145 prompt
= getenv ("PS2");
3149 printf_unfiltered ("%s ", prompt
);
3150 gdb_flush (gdb_stdout
);
3152 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3155 error_no_arg (_("one or more choice numbers"));
3159 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3160 order, as given in args. Choices are validated. */
3166 while (isspace (*args
))
3168 if (*args
== '\0' && n_chosen
== 0)
3169 error_no_arg (_("one or more choice numbers"));
3170 else if (*args
== '\0')
3173 choice
= strtol (args
, &args2
, 10);
3174 if (args
== args2
|| choice
< 0
3175 || choice
> n_choices
+ first_choice
- 1)
3176 error (_("Argument must be choice number"));
3180 error (_("cancelled"));
3182 if (choice
< first_choice
)
3184 n_chosen
= n_choices
;
3185 for (j
= 0; j
< n_choices
; j
+= 1)
3189 choice
-= first_choice
;
3191 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3195 if (j
< 0 || choice
!= choices
[j
])
3198 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3199 choices
[k
+ 1] = choices
[k
];
3200 choices
[j
+ 1] = choice
;
3205 if (n_chosen
> max_results
)
3206 error (_("Select no more than %d of the above"), max_results
);
3211 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3212 on the function identified by SYM and BLOCK, and taking NARGS
3213 arguments. Update *EXPP as needed to hold more space. */
3216 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3217 int oplen
, struct symbol
*sym
,
3218 struct block
*block
)
3220 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3221 symbol, -oplen for operator being replaced). */
3222 struct expression
*newexp
= (struct expression
*)
3223 xmalloc (sizeof (struct expression
)
3224 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3225 struct expression
*exp
= *expp
;
3227 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3228 newexp
->language_defn
= exp
->language_defn
;
3229 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3230 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3231 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3233 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3234 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3236 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3237 newexp
->elts
[pc
+ 4].block
= block
;
3238 newexp
->elts
[pc
+ 5].symbol
= sym
;
3244 /* Type-class predicates */
3246 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3250 numeric_type_p (struct type
*type
)
3256 switch (TYPE_CODE (type
))
3261 case TYPE_CODE_RANGE
:
3262 return (type
== TYPE_TARGET_TYPE (type
)
3263 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3270 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3273 integer_type_p (struct type
*type
)
3279 switch (TYPE_CODE (type
))
3283 case TYPE_CODE_RANGE
:
3284 return (type
== TYPE_TARGET_TYPE (type
)
3285 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3292 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3295 scalar_type_p (struct type
*type
)
3301 switch (TYPE_CODE (type
))
3304 case TYPE_CODE_RANGE
:
3305 case TYPE_CODE_ENUM
:
3314 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3317 discrete_type_p (struct type
*type
)
3323 switch (TYPE_CODE (type
))
3326 case TYPE_CODE_RANGE
:
3327 case TYPE_CODE_ENUM
:
3335 /* Returns non-zero if OP with operands in the vector ARGS could be
3336 a user-defined function. Errs on the side of pre-defined operators
3337 (i.e., result 0). */
3340 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3342 struct type
*type0
=
3343 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3344 struct type
*type1
=
3345 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3359 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3363 case BINOP_BITWISE_AND
:
3364 case BINOP_BITWISE_IOR
:
3365 case BINOP_BITWISE_XOR
:
3366 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3369 case BINOP_NOTEQUAL
:
3374 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3378 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3379 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3380 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3381 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3382 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3383 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
))
3384 != TYPE_CODE_ARRAY
))));
3387 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3391 case UNOP_LOGICAL_NOT
:
3393 return (!numeric_type_p (type0
));
3400 /* NOTE: In the following, we assume that a renaming type's name may
3401 have an ___XD suffix. It would be nice if this went away at some
3404 /* If TYPE encodes a renaming, returns the renaming suffix, which
3405 is XR for an object renaming, XRP for a procedure renaming, XRE for
3406 an exception renaming, and XRS for a subprogram renaming. Returns
3407 NULL if NAME encodes none of these. */
3410 ada_renaming_type (struct type
*type
)
3412 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3414 const char *name
= type_name_no_tag (type
);
3415 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3417 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3426 /* Return non-zero iff SYM encodes an object renaming. */
3429 ada_is_object_renaming (struct symbol
*sym
)
3431 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3432 return renaming_type
!= NULL
3433 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3436 /* Assuming that SYM encodes a non-object renaming, returns the original
3437 name of the renamed entity. The name is good until the end of
3441 ada_simple_renamed_entity (struct symbol
*sym
)
3444 const char *raw_name
;
3448 type
= SYMBOL_TYPE (sym
);
3449 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3450 error (_("Improperly encoded renaming."));
3452 raw_name
= TYPE_FIELD_NAME (type
, 0);
3453 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3455 error (_("Improperly encoded renaming."));
3457 result
= xmalloc (len
+ 1);
3458 strncpy (result
, raw_name
, len
);
3459 result
[len
] = '\000';
3464 /* Evaluation: Function Calls */
3466 /* Return an lvalue containing the value VAL. This is the identity on
3467 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3468 on the stack, using and updating *SP as the stack pointer, and
3469 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3471 static struct value
*
3472 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3474 if (! VALUE_LVAL (val
))
3476 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3478 /* The following is taken from the structure-return code in
3479 call_function_by_hand. FIXME: Therefore, some refactoring seems
3481 if (INNER_THAN (1, 2))
3483 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3484 reserving sufficient space. */
3486 if (gdbarch_frame_align_p (current_gdbarch
))
3487 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3488 VALUE_ADDRESS (val
) = *sp
;
3492 /* Stack grows upward. Align the frame, allocate space, and
3493 then again, re-align the frame. */
3494 if (gdbarch_frame_align_p (current_gdbarch
))
3495 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3496 VALUE_ADDRESS (val
) = *sp
;
3498 if (gdbarch_frame_align_p (current_gdbarch
))
3499 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3502 write_memory (VALUE_ADDRESS (val
), VALUE_CONTENTS_RAW (val
), len
);
3508 /* Return the value ACTUAL, converted to be an appropriate value for a
3509 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3510 allocating any necessary descriptors (fat pointers), or copies of
3511 values not residing in memory, updating it as needed. */
3513 static struct value
*
3514 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3517 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3518 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3519 struct type
*formal_target
=
3520 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3521 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3522 struct type
*actual_target
=
3523 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3524 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3526 if (ada_is_array_descriptor_type (formal_target
)
3527 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3528 return make_array_descriptor (formal_type
, actual
, sp
);
3529 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3531 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3532 && ada_is_array_descriptor_type (actual_target
))
3533 return desc_data (actual
);
3534 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3536 if (VALUE_LVAL (actual
) != lval_memory
)
3539 actual_type
= ada_check_typedef (value_type (actual
));
3540 val
= allocate_value (actual_type
);
3541 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3542 (char *) VALUE_CONTENTS (actual
),
3543 TYPE_LENGTH (actual_type
));
3544 actual
= ensure_lval (val
, sp
);
3546 return value_addr (actual
);
3549 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3550 return ada_value_ind (actual
);
3556 /* Push a descriptor of type TYPE for array value ARR on the stack at
3557 *SP, updating *SP to reflect the new descriptor. Return either
3558 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3559 to-descriptor type rather than a descriptor type), a struct value *
3560 representing a pointer to this descriptor. */
3562 static struct value
*
3563 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3565 struct type
*bounds_type
= desc_bounds_type (type
);
3566 struct type
*desc_type
= desc_base_type (type
);
3567 struct value
*descriptor
= allocate_value (desc_type
);
3568 struct value
*bounds
= allocate_value (bounds_type
);
3571 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3573 modify_general_field (VALUE_CONTENTS (bounds
),
3574 value_as_long (ada_array_bound (arr
, i
, 0)),
3575 desc_bound_bitpos (bounds_type
, i
, 0),
3576 desc_bound_bitsize (bounds_type
, i
, 0));
3577 modify_general_field (VALUE_CONTENTS (bounds
),
3578 value_as_long (ada_array_bound (arr
, i
, 1)),
3579 desc_bound_bitpos (bounds_type
, i
, 1),
3580 desc_bound_bitsize (bounds_type
, i
, 1));
3583 bounds
= ensure_lval (bounds
, sp
);
3585 modify_general_field (VALUE_CONTENTS (descriptor
),
3586 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3587 fat_pntr_data_bitpos (desc_type
),
3588 fat_pntr_data_bitsize (desc_type
));
3590 modify_general_field (VALUE_CONTENTS (descriptor
),
3591 VALUE_ADDRESS (bounds
),
3592 fat_pntr_bounds_bitpos (desc_type
),
3593 fat_pntr_bounds_bitsize (desc_type
));
3595 descriptor
= ensure_lval (descriptor
, sp
);
3597 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3598 return value_addr (descriptor
);
3604 /* Assuming a dummy frame has been established on the target, perform any
3605 conversions needed for calling function FUNC on the NARGS actual
3606 parameters in ARGS, other than standard C conversions. Does
3607 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3608 does not match the number of arguments expected. Use *SP as a
3609 stack pointer for additional data that must be pushed, updating its
3613 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3618 if (TYPE_NFIELDS (value_type (func
)) == 0
3619 || nargs
!= TYPE_NFIELDS (value_type (func
)))
3622 for (i
= 0; i
< nargs
; i
+= 1)
3624 convert_actual (args
[i
], TYPE_FIELD_TYPE (value_type (func
), i
), sp
);
3627 /* Dummy definitions for an experimental caching module that is not
3628 * used in the public sources. */
3631 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3632 struct symbol
**sym
, struct block
**block
,
3633 struct symtab
**symtab
)
3639 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3640 struct block
*block
, struct symtab
*symtab
)
3646 /* Return the result of a standard (literal, C-like) lookup of NAME in
3647 given DOMAIN, visible from lexical block BLOCK. */
3649 static struct symbol
*
3650 standard_lookup (const char *name
, const struct block
*block
,
3654 struct symtab
*symtab
;
3656 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3659 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3660 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3665 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3666 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3667 since they contend in overloading in the same way. */
3669 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3673 for (i
= 0; i
< n
; i
+= 1)
3674 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3675 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3676 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3682 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3683 struct types. Otherwise, they may not. */
3686 equiv_types (struct type
*type0
, struct type
*type1
)
3690 if (type0
== NULL
|| type1
== NULL
3691 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3693 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3694 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3695 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3696 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3702 /* True iff SYM0 represents the same entity as SYM1, or one that is
3703 no more defined than that of SYM1. */
3706 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3710 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3711 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3714 switch (SYMBOL_CLASS (sym0
))
3720 struct type
*type0
= SYMBOL_TYPE (sym0
);
3721 struct type
*type1
= SYMBOL_TYPE (sym1
);
3722 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3723 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3724 int len0
= strlen (name0
);
3726 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3727 && (equiv_types (type0
, type1
)
3728 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3729 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3732 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3733 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3739 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3740 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3743 add_defn_to_vec (struct obstack
*obstackp
,
3745 struct block
*block
, struct symtab
*symtab
)
3749 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3751 if (SYMBOL_TYPE (sym
) != NULL
)
3752 SYMBOL_TYPE (sym
) = ada_check_typedef (SYMBOL_TYPE (sym
));
3753 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3755 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3757 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3759 prevDefns
[i
].sym
= sym
;
3760 prevDefns
[i
].block
= block
;
3761 prevDefns
[i
].symtab
= symtab
;
3767 struct ada_symbol_info info
;
3771 info
.symtab
= symtab
;
3772 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3776 /* Number of ada_symbol_info structures currently collected in
3777 current vector in *OBSTACKP. */
3780 num_defns_collected (struct obstack
*obstackp
)
3782 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3785 /* Vector of ada_symbol_info structures currently collected in current
3786 vector in *OBSTACKP. If FINISH, close off the vector and return
3787 its final address. */
3789 static struct ada_symbol_info
*
3790 defns_collected (struct obstack
*obstackp
, int finish
)
3793 return obstack_finish (obstackp
);
3795 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3798 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3799 Check the global symbols if GLOBAL, the static symbols if not.
3800 Do wild-card match if WILD. */
3802 static struct partial_symbol
*
3803 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3804 int global
, domain_enum
namespace, int wild
)
3806 struct partial_symbol
**start
;
3807 int name_len
= strlen (name
);
3808 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3817 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3818 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3822 for (i
= 0; i
< length
; i
+= 1)
3824 struct partial_symbol
*psym
= start
[i
];
3826 if (SYMBOL_DOMAIN (psym
) == namespace
3827 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3841 int M
= (U
+ i
) >> 1;
3842 struct partial_symbol
*psym
= start
[M
];
3843 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3845 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3847 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
3858 struct partial_symbol
*psym
= start
[i
];
3860 if (SYMBOL_DOMAIN (psym
) == namespace)
3862 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
3870 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3884 int M
= (U
+ i
) >> 1;
3885 struct partial_symbol
*psym
= start
[M
];
3886 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
3888 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
3890 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
3901 struct partial_symbol
*psym
= start
[i
];
3903 if (SYMBOL_DOMAIN (psym
) == namespace)
3907 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
3910 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
3912 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
3922 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3932 /* Find a symbol table containing symbol SYM or NULL if none. */
3934 static struct symtab
*
3935 symtab_for_sym (struct symbol
*sym
)
3938 struct objfile
*objfile
;
3940 struct symbol
*tmp_sym
;
3941 struct dict_iterator iter
;
3944 ALL_SYMTABS (objfile
, s
)
3946 switch (SYMBOL_CLASS (sym
))
3954 case LOC_CONST_BYTES
:
3955 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3956 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3958 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3959 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3965 switch (SYMBOL_CLASS (sym
))
3971 case LOC_REGPARM_ADDR
:
3976 case LOC_BASEREG_ARG
:
3978 case LOC_COMPUTED_ARG
:
3979 for (j
= FIRST_LOCAL_BLOCK
;
3980 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3982 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3983 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3994 /* Return a minimal symbol matching NAME according to Ada decoding
3995 rules. Returns NULL if there is no such minimal symbol. Names
3996 prefixed with "standard__" are handled specially: "standard__" is
3997 first stripped off, and only static and global symbols are searched. */
3999 struct minimal_symbol
*
4000 ada_lookup_simple_minsym (const char *name
)
4002 struct objfile
*objfile
;
4003 struct minimal_symbol
*msymbol
;
4006 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4008 name
+= sizeof ("standard__") - 1;
4012 wild_match
= (strstr (name
, "__") == NULL
);
4014 ALL_MSYMBOLS (objfile
, msymbol
)
4016 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4017 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4024 /* For all subprograms that statically enclose the subprogram of the
4025 selected frame, add symbols matching identifier NAME in DOMAIN
4026 and their blocks to the list of data in OBSTACKP, as for
4027 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4031 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4032 const char *name
, domain_enum
namespace,
4037 /* FIXME: The next two routines belong in symtab.c */
4040 restore_language (void *lang
)
4042 set_language ((enum language
) lang
);
4045 /* As for lookup_symbol, but performed as if the current language
4049 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4050 domain_enum domain
, enum language lang
,
4051 int *is_a_field_of_this
, struct symtab
**symtab
)
4053 struct cleanup
*old_chain
4054 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4055 struct symbol
*result
;
4056 set_language (lang
);
4057 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4058 do_cleanups (old_chain
);
4062 /* True if TYPE is definitely an artificial type supplied to a symbol
4063 for which no debugging information was given in the symbol file. */
4066 is_nondebugging_type (struct type
*type
)
4068 char *name
= ada_type_name (type
);
4069 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4072 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4073 duplicate other symbols in the list (The only case I know of where
4074 this happens is when object files containing stabs-in-ecoff are
4075 linked with files containing ordinary ecoff debugging symbols (or no
4076 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4077 Returns the number of items in the modified list. */
4080 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4087 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4088 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4089 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4091 for (j
= 0; j
< nsyms
; j
+= 1)
4094 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4095 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4096 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4097 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4098 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4099 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4102 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4103 syms
[k
- 1] = syms
[k
];
4116 /* Given a type that corresponds to a renaming entity, use the type name
4117 to extract the scope (package name or function name, fully qualified,
4118 and following the GNAT encoding convention) where this renaming has been
4119 defined. The string returned needs to be deallocated after use. */
4122 xget_renaming_scope (struct type
*renaming_type
)
4124 /* The renaming types adhere to the following convention:
4125 <scope>__<rename>___<XR extension>.
4126 So, to extract the scope, we search for the "___XR" extension,
4127 and then backtrack until we find the first "__". */
4129 const char *name
= type_name_no_tag (renaming_type
);
4130 char *suffix
= strstr (name
, "___XR");
4135 /* Now, backtrack a bit until we find the first "__". Start looking
4136 at suffix - 3, as the <rename> part is at least one character long. */
4138 for (last
= suffix
- 3; last
> name
; last
--)
4139 if (last
[0] == '_' && last
[1] == '_')
4142 /* Make a copy of scope and return it. */
4144 scope_len
= last
- name
;
4145 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4147 strncpy (scope
, name
, scope_len
);
4148 scope
[scope_len
] = '\0';
4153 /* Return nonzero if NAME corresponds to a package name. */
4156 is_package_name (const char *name
)
4158 /* Here, We take advantage of the fact that no symbols are generated
4159 for packages, while symbols are generated for each function.
4160 So the condition for NAME represent a package becomes equivalent
4161 to NAME not existing in our list of symbols. There is only one
4162 small complication with library-level functions (see below). */
4166 /* If it is a function that has not been defined at library level,
4167 then we should be able to look it up in the symbols. */
4168 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4171 /* Library-level function names start with "_ada_". See if function
4172 "_ada_" followed by NAME can be found. */
4174 /* Do a quick check that NAME does not contain "__", since library-level
4175 functions names can not contain "__" in them. */
4176 if (strstr (name
, "__") != NULL
)
4179 fun_name
= xstrprintf ("_ada_%s", name
);
4181 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4184 /* Return nonzero if SYM corresponds to a renaming entity that is
4185 visible from FUNCTION_NAME. */
4188 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4190 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4192 make_cleanup (xfree
, scope
);
4194 /* If the rename has been defined in a package, then it is visible. */
4195 if (is_package_name (scope
))
4198 /* Check that the rename is in the current function scope by checking
4199 that its name starts with SCOPE. */
4201 /* If the function name starts with "_ada_", it means that it is
4202 a library-level function. Strip this prefix before doing the
4203 comparison, as the encoding for the renaming does not contain
4205 if (strncmp (function_name
, "_ada_", 5) == 0)
4208 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4211 /* Iterates over the SYMS list and remove any entry that corresponds to
4212 a renaming entity that is not visible from the function associated
4216 GNAT emits a type following a specified encoding for each renaming
4217 entity. Unfortunately, STABS currently does not support the definition
4218 of types that are local to a given lexical block, so all renamings types
4219 are emitted at library level. As a consequence, if an application
4220 contains two renaming entities using the same name, and a user tries to
4221 print the value of one of these entities, the result of the ada symbol
4222 lookup will also contain the wrong renaming type.
4224 This function partially covers for this limitation by attempting to
4225 remove from the SYMS list renaming symbols that should be visible
4226 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4227 method with the current information available. The implementation
4228 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4230 - When the user tries to print a rename in a function while there
4231 is another rename entity defined in a package: Normally, the
4232 rename in the function has precedence over the rename in the
4233 package, so the latter should be removed from the list. This is
4234 currently not the case.
4236 - This function will incorrectly remove valid renames if
4237 the CURRENT_BLOCK corresponds to a function which symbol name
4238 has been changed by an "Export" pragma. As a consequence,
4239 the user will be unable to print such rename entities. */
4242 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4243 int nsyms
, struct block
*current_block
)
4245 struct symbol
*current_function
;
4246 char *current_function_name
;
4249 /* Extract the function name associated to CURRENT_BLOCK.
4250 Abort if unable to do so. */
4252 if (current_block
== NULL
)
4255 current_function
= block_function (current_block
);
4256 if (current_function
== NULL
)
4259 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4260 if (current_function_name
== NULL
)
4263 /* Check each of the symbols, and remove it from the list if it is
4264 a type corresponding to a renaming that is out of the scope of
4265 the current block. */
4270 if (ada_is_object_renaming (syms
[i
].sym
)
4271 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4274 for (j
= i
+ 1; j
< nsyms
; j
++)
4275 syms
[j
- 1] = syms
[j
];
4285 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4286 scope and in global scopes, returning the number of matches. Sets
4287 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4288 indicating the symbols found and the blocks and symbol tables (if
4289 any) in which they were found. This vector are transient---good only to
4290 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4291 symbol match within the nest of blocks whose innermost member is BLOCK0,
4292 is the one match returned (no other matches in that or
4293 enclosing blocks is returned). If there are any matches in or
4294 surrounding BLOCK0, then these alone are returned. Otherwise, the
4295 search extends to global and file-scope (static) symbol tables.
4296 Names prefixed with "standard__" are handled specially: "standard__"
4297 is first stripped off, and only static and global symbols are searched. */
4300 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4301 domain_enum
namespace,
4302 struct ada_symbol_info
**results
)
4306 struct partial_symtab
*ps
;
4307 struct blockvector
*bv
;
4308 struct objfile
*objfile
;
4309 struct block
*block
;
4311 struct minimal_symbol
*msymbol
;
4317 obstack_free (&symbol_list_obstack
, NULL
);
4318 obstack_init (&symbol_list_obstack
);
4322 /* Search specified block and its superiors. */
4324 wild_match
= (strstr (name0
, "__") == NULL
);
4326 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4327 needed, but adding const will
4328 have a cascade effect. */
4329 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4333 name
= name0
+ sizeof ("standard__") - 1;
4337 while (block
!= NULL
)
4340 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4341 namespace, NULL
, NULL
, wild_match
);
4343 /* If we found a non-function match, assume that's the one. */
4344 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4345 num_defns_collected (&symbol_list_obstack
)))
4348 block
= BLOCK_SUPERBLOCK (block
);
4351 /* If no luck so far, try to find NAME as a local symbol in some lexically
4352 enclosing subprogram. */
4353 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4354 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4355 name
, namespace, wild_match
);
4357 /* If we found ANY matches among non-global symbols, we're done. */
4359 if (num_defns_collected (&symbol_list_obstack
) > 0)
4363 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4366 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4370 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4371 tables, and psymtab's. */
4373 ALL_SYMTABS (objfile
, s
)
4378 bv
= BLOCKVECTOR (s
);
4379 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4380 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4381 objfile
, s
, wild_match
);
4384 if (namespace == VAR_DOMAIN
)
4386 ALL_MSYMBOLS (objfile
, msymbol
)
4388 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4390 switch (MSYMBOL_TYPE (msymbol
))
4392 case mst_solib_trampoline
:
4395 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4398 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4400 bv
= BLOCKVECTOR (s
);
4401 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4402 ada_add_block_symbols (&symbol_list_obstack
, block
,
4403 SYMBOL_LINKAGE_NAME (msymbol
),
4404 namespace, objfile
, s
, wild_match
);
4406 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4408 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4409 ada_add_block_symbols (&symbol_list_obstack
, block
,
4410 SYMBOL_LINKAGE_NAME (msymbol
),
4411 namespace, objfile
, s
,
4420 ALL_PSYMTABS (objfile
, ps
)
4424 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4426 s
= PSYMTAB_TO_SYMTAB (ps
);
4429 bv
= BLOCKVECTOR (s
);
4430 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4431 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4432 namespace, objfile
, s
, wild_match
);
4436 /* Now add symbols from all per-file blocks if we've gotten no hits
4437 (Not strictly correct, but perhaps better than an error).
4438 Do the symtabs first, then check the psymtabs. */
4440 if (num_defns_collected (&symbol_list_obstack
) == 0)
4443 ALL_SYMTABS (objfile
, s
)
4448 bv
= BLOCKVECTOR (s
);
4449 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4450 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4451 objfile
, s
, wild_match
);
4454 ALL_PSYMTABS (objfile
, ps
)
4458 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4460 s
= PSYMTAB_TO_SYMTAB (ps
);
4461 bv
= BLOCKVECTOR (s
);
4464 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4465 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4466 namespace, objfile
, s
, wild_match
);
4472 ndefns
= num_defns_collected (&symbol_list_obstack
);
4473 *results
= defns_collected (&symbol_list_obstack
, 1);
4475 ndefns
= remove_extra_symbols (*results
, ndefns
);
4478 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4480 if (ndefns
== 1 && cacheIfUnique
)
4481 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4482 (*results
)[0].symtab
);
4484 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4485 (struct block
*) block0
);
4490 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4491 scope and in global scopes, or NULL if none. NAME is folded and
4492 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4493 choosing the first symbol if there are multiple choices.
4494 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4495 table in which the symbol was found (in both cases, these
4496 assignments occur only if the pointers are non-null). */
4499 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4500 domain_enum
namespace, int *is_a_field_of_this
,
4501 struct symtab
**symtab
)
4503 struct ada_symbol_info
*candidates
;
4506 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4507 block0
, namespace, &candidates
);
4509 if (n_candidates
== 0)
4512 if (is_a_field_of_this
!= NULL
)
4513 *is_a_field_of_this
= 0;
4517 *symtab
= candidates
[0].symtab
;
4518 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4520 struct objfile
*objfile
;
4523 struct blockvector
*bv
;
4525 /* Search the list of symtabs for one which contains the
4526 address of the start of this block. */
4527 ALL_SYMTABS (objfile
, s
)
4529 bv
= BLOCKVECTOR (s
);
4530 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4531 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4532 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4535 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4537 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4541 return candidates
[0].sym
;
4544 static struct symbol
*
4545 ada_lookup_symbol_nonlocal (const char *name
,
4546 const char *linkage_name
,
4547 const struct block
*block
,
4548 const domain_enum domain
, struct symtab
**symtab
)
4550 if (linkage_name
== NULL
)
4551 linkage_name
= name
;
4552 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4557 /* True iff STR is a possible encoded suffix of a normal Ada name
4558 that is to be ignored for matching purposes. Suffixes of parallel
4559 names (e.g., XVE) are not included here. Currently, the possible suffixes
4560 are given by either of the regular expression:
4562 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4564 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4565 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4569 is_name_suffix (const char *str
)
4572 const char *matching
;
4573 const int len
= strlen (str
);
4575 /* (__[0-9]+)?\.[0-9]+ */
4577 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4580 while (isdigit (matching
[0]))
4582 if (matching
[0] == '\0')
4586 if (matching
[0] == '.')
4589 while (isdigit (matching
[0]))
4591 if (matching
[0] == '\0')
4596 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4599 while (isdigit (matching
[0]))
4601 if (matching
[0] == '\0')
4605 /* ??? We should not modify STR directly, as we are doing below. This
4606 is fine in this case, but may become problematic later if we find
4607 that this alternative did not work, and want to try matching
4608 another one from the begining of STR. Since we modified it, we
4609 won't be able to find the begining of the string anymore! */
4613 while (str
[0] != '_' && str
[0] != '\0')
4615 if (str
[0] != 'n' && str
[0] != 'b')
4620 if (str
[0] == '\000')
4624 if (str
[1] != '_' || str
[2] == '\000')
4628 if (strcmp (str
+ 3, "JM") == 0)
4630 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4631 the LJM suffix in favor of the JM one. But we will
4632 still accept LJM as a valid suffix for a reasonable
4633 amount of time, just to allow ourselves to debug programs
4634 compiled using an older version of GNAT. */
4635 if (strcmp (str
+ 3, "LJM") == 0)
4639 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4640 || str
[4] == 'U' || str
[4] == 'P')
4642 if (str
[4] == 'R' && str
[5] != 'T')
4646 if (!isdigit (str
[2]))
4648 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4649 if (!isdigit (str
[k
]) && str
[k
] != '_')
4653 if (str
[0] == '$' && isdigit (str
[1]))
4655 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4656 if (!isdigit (str
[k
]) && str
[k
] != '_')
4663 /* Return nonzero if the given string starts with a dot ('.')
4664 followed by zero or more digits.
4666 Note: brobecker/2003-11-10: A forward declaration has not been
4667 added at the begining of this file yet, because this function
4668 is only used to work around a problem found during wild matching
4669 when trying to match minimal symbol names against symbol names
4670 obtained from dwarf-2 data. This function is therefore currently
4671 only used in wild_match() and is likely to be deleted when the
4672 problem in dwarf-2 is fixed. */
4675 is_dot_digits_suffix (const char *str
)
4681 while (isdigit (str
[0]))
4683 return (str
[0] == '\0');
4686 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4687 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4688 informational suffixes of NAME (i.e., for which is_name_suffix is
4692 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4698 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4699 stored in the symbol table for nested function names is sometimes
4700 different from the name of the associated entity stored in
4701 the dwarf-2 data: This is the case for nested subprograms, where
4702 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4703 while the symbol name from the dwarf-2 data does not.
4705 Although the DWARF-2 standard documents that entity names stored
4706 in the dwarf-2 data should be identical to the name as seen in
4707 the source code, GNAT takes a different approach as we already use
4708 a special encoding mechanism to convey the information so that
4709 a C debugger can still use the information generated to debug
4710 Ada programs. A corollary is that the symbol names in the dwarf-2
4711 data should match the names found in the symbol table. I therefore
4712 consider this issue as a compiler defect.
4714 Until the compiler is properly fixed, we work-around the problem
4715 by ignoring such suffixes during the match. We do so by making
4716 a copy of PATN0 and NAME0, and then by stripping such a suffix
4717 if present. We then perform the match on the resulting strings. */
4720 name_len
= strlen (name0
);
4722 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4723 strcpy (name
, name0
);
4724 dot
= strrchr (name
, '.');
4725 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4728 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4729 strncpy (patn
, patn0
, patn_len
);
4730 patn
[patn_len
] = '\0';
4731 dot
= strrchr (patn
, '.');
4732 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4735 patn_len
= dot
- patn
;
4739 /* Now perform the wild match. */
4741 name_len
= strlen (name
);
4742 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4743 && strncmp (patn
, name
+ 5, patn_len
) == 0
4744 && is_name_suffix (name
+ patn_len
+ 5))
4747 while (name_len
>= patn_len
)
4749 if (strncmp (patn
, name
, patn_len
) == 0
4750 && is_name_suffix (name
+ patn_len
))
4758 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4763 if (!islower (name
[2]))
4770 if (!islower (name
[1]))
4781 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4782 vector *defn_symbols, updating the list of symbols in OBSTACKP
4783 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4784 OBJFILE is the section containing BLOCK.
4785 SYMTAB is recorded with each symbol added. */
4788 ada_add_block_symbols (struct obstack
*obstackp
,
4789 struct block
*block
, const char *name
,
4790 domain_enum domain
, struct objfile
*objfile
,
4791 struct symtab
*symtab
, int wild
)
4793 struct dict_iterator iter
;
4794 int name_len
= strlen (name
);
4795 /* A matching argument symbol, if any. */
4796 struct symbol
*arg_sym
;
4797 /* Set true when we find a matching non-argument symbol. */
4806 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4808 if (SYMBOL_DOMAIN (sym
) == domain
4809 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
4811 switch (SYMBOL_CLASS (sym
))
4817 case LOC_REGPARM_ADDR
:
4818 case LOC_BASEREG_ARG
:
4819 case LOC_COMPUTED_ARG
:
4822 case LOC_UNRESOLVED
:
4826 add_defn_to_vec (obstackp
,
4827 fixup_symbol_section (sym
, objfile
),
4836 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4838 if (SYMBOL_DOMAIN (sym
) == domain
)
4840 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
4842 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
4844 switch (SYMBOL_CLASS (sym
))
4850 case LOC_REGPARM_ADDR
:
4851 case LOC_BASEREG_ARG
:
4852 case LOC_COMPUTED_ARG
:
4855 case LOC_UNRESOLVED
:
4859 add_defn_to_vec (obstackp
,
4860 fixup_symbol_section (sym
, objfile
),
4869 if (!found_sym
&& arg_sym
!= NULL
)
4871 add_defn_to_vec (obstackp
,
4872 fixup_symbol_section (arg_sym
, objfile
),
4881 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4883 if (SYMBOL_DOMAIN (sym
) == domain
)
4887 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
4890 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
4892 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
4897 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
4899 switch (SYMBOL_CLASS (sym
))
4905 case LOC_REGPARM_ADDR
:
4906 case LOC_BASEREG_ARG
:
4907 case LOC_COMPUTED_ARG
:
4910 case LOC_UNRESOLVED
:
4914 add_defn_to_vec (obstackp
,
4915 fixup_symbol_section (sym
, objfile
),
4923 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4924 They aren't parameters, right? */
4925 if (!found_sym
&& arg_sym
!= NULL
)
4927 add_defn_to_vec (obstackp
,
4928 fixup_symbol_section (arg_sym
, objfile
),
4936 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
4937 to be invisible to users. */
4940 ada_is_ignored_field (struct type
*type
, int field_num
)
4942 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
4946 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
4947 return (name
== NULL
4948 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
4952 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
4953 pointer or reference type whose ultimate target has a tag field. */
4956 ada_is_tagged_type (struct type
*type
, int refok
)
4958 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
4961 /* True iff TYPE represents the type of X'Tag */
4964 ada_is_tag_type (struct type
*type
)
4966 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
4970 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
4971 return (name
!= NULL
4972 && strcmp (name
, "ada__tags__dispatch_table") == 0);
4976 /* The type of the tag on VAL. */
4979 ada_tag_type (struct value
*val
)
4981 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
4984 /* The value of the tag on VAL. */
4987 ada_value_tag (struct value
*val
)
4989 return ada_value_struct_elt (val
, "_tag", "record");
4992 /* The value of the tag on the object of type TYPE whose contents are
4993 saved at VALADDR, if it is non-null, or is at memory address
4996 static struct value
*
4997 value_tag_from_contents_and_address (struct type
*type
, char *valaddr
,
5000 int tag_byte_offset
, dummy1
, dummy2
;
5001 struct type
*tag_type
;
5002 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5005 char *valaddr1
= (valaddr
== NULL
) ? NULL
: valaddr
+ tag_byte_offset
;
5006 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5008 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5013 static struct type
*
5014 type_from_tag (struct value
*tag
)
5016 const char *type_name
= ada_tag_name (tag
);
5017 if (type_name
!= NULL
)
5018 return ada_find_any_type (ada_encode (type_name
));
5028 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5029 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5030 The value stored in ARGS->name is valid until the next call to
5034 ada_tag_name_1 (void *args0
)
5036 struct tag_args
*args
= (struct tag_args
*) args0
;
5037 static char name
[1024];
5041 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
5044 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
5047 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5048 for (p
= name
; *p
!= '\0'; p
+= 1)
5055 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5059 ada_tag_name (struct value
*tag
)
5061 struct tag_args args
;
5062 if (!ada_is_tag_type (value_type (tag
)))
5066 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5070 /* The parent type of TYPE, or NULL if none. */
5073 ada_parent_type (struct type
*type
)
5077 type
= ada_check_typedef (type
);
5079 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5082 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5083 if (ada_is_parent_field (type
, i
))
5084 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5089 /* True iff field number FIELD_NUM of structure type TYPE contains the
5090 parent-type (inherited) fields of a derived type. Assumes TYPE is
5091 a structure type with at least FIELD_NUM+1 fields. */
5094 ada_is_parent_field (struct type
*type
, int field_num
)
5096 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5097 return (name
!= NULL
5098 && (strncmp (name
, "PARENT", 6) == 0
5099 || strncmp (name
, "_parent", 7) == 0));
5102 /* True iff field number FIELD_NUM of structure type TYPE is a
5103 transparent wrapper field (which should be silently traversed when doing
5104 field selection and flattened when printing). Assumes TYPE is a
5105 structure type with at least FIELD_NUM+1 fields. Such fields are always
5109 ada_is_wrapper_field (struct type
*type
, int field_num
)
5111 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5112 return (name
!= NULL
5113 && (strncmp (name
, "PARENT", 6) == 0
5114 || strcmp (name
, "REP") == 0
5115 || strncmp (name
, "_parent", 7) == 0
5116 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5119 /* True iff field number FIELD_NUM of structure or union type TYPE
5120 is a variant wrapper. Assumes TYPE is a structure type with at least
5121 FIELD_NUM+1 fields. */
5124 ada_is_variant_part (struct type
*type
, int field_num
)
5126 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5127 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5128 || (is_dynamic_field (type
, field_num
)
5129 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5130 == TYPE_CODE_UNION
)));
5133 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5134 whose discriminants are contained in the record type OUTER_TYPE,
5135 returns the type of the controlling discriminant for the variant. */
5138 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5140 char *name
= ada_variant_discrim_name (var_type
);
5142 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5144 return builtin_type_int
;
5149 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5150 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5151 represents a 'when others' clause; otherwise 0. */
5154 ada_is_others_clause (struct type
*type
, int field_num
)
5156 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5157 return (name
!= NULL
&& name
[0] == 'O');
5160 /* Assuming that TYPE0 is the type of the variant part of a record,
5161 returns the name of the discriminant controlling the variant.
5162 The value is valid until the next call to ada_variant_discrim_name. */
5165 ada_variant_discrim_name (struct type
*type0
)
5167 static char *result
= NULL
;
5168 static size_t result_len
= 0;
5171 const char *discrim_end
;
5172 const char *discrim_start
;
5174 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5175 type
= TYPE_TARGET_TYPE (type0
);
5179 name
= ada_type_name (type
);
5181 if (name
== NULL
|| name
[0] == '\000')
5184 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5187 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5190 if (discrim_end
== name
)
5193 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5196 if (discrim_start
== name
+ 1)
5198 if ((discrim_start
> name
+ 3
5199 && strncmp (discrim_start
- 3, "___", 3) == 0)
5200 || discrim_start
[-1] == '.')
5204 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5205 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5206 result
[discrim_end
- discrim_start
] = '\0';
5210 /* Scan STR for a subtype-encoded number, beginning at position K.
5211 Put the position of the character just past the number scanned in
5212 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5213 Return 1 if there was a valid number at the given position, and 0
5214 otherwise. A "subtype-encoded" number consists of the absolute value
5215 in decimal, followed by the letter 'm' to indicate a negative number.
5216 Assumes 0m does not occur. */
5219 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5223 if (!isdigit (str
[k
]))
5226 /* Do it the hard way so as not to make any assumption about
5227 the relationship of unsigned long (%lu scan format code) and
5230 while (isdigit (str
[k
]))
5232 RU
= RU
* 10 + (str
[k
] - '0');
5239 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5245 /* NOTE on the above: Technically, C does not say what the results of
5246 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5247 number representable as a LONGEST (although either would probably work
5248 in most implementations). When RU>0, the locution in the then branch
5249 above is always equivalent to the negative of RU. */
5256 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5257 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5258 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5261 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5263 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5276 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5285 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5286 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5288 if (val
>= L
&& val
<= U
)
5300 /* FIXME: Lots of redundancy below. Try to consolidate. */
5302 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5303 ARG_TYPE, extract and return the value of one of its (non-static)
5304 fields. FIELDNO says which field. Differs from value_primitive_field
5305 only in that it can handle packed values of arbitrary type. */
5307 static struct value
*
5308 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5309 struct type
*arg_type
)
5313 arg_type
= ada_check_typedef (arg_type
);
5314 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5316 /* Handle packed fields. */
5318 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5320 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5321 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5323 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5324 offset
+ bit_pos
/ 8,
5325 bit_pos
% 8, bit_size
, type
);
5328 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5331 /* Find field with name NAME in object of type TYPE. If found, return 1
5332 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
5333 OFFSET + the byte offset of the field within an object of that type,
5334 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
5335 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
5336 Looks inside wrappers for the field. Returns 0 if field not
5339 find_struct_field (char *name
, struct type
*type
, int offset
,
5340 struct type
**field_type_p
,
5341 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
5345 type
= ada_check_typedef (type
);
5346 *field_type_p
= NULL
;
5347 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
5349 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5351 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
5352 int fld_offset
= offset
+ bit_pos
/ 8;
5353 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5355 if (t_field_name
== NULL
)
5358 else if (field_name_match (t_field_name
, name
))
5360 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
5361 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
5362 *byte_offset_p
= fld_offset
;
5363 *bit_offset_p
= bit_pos
% 8;
5364 *bit_size_p
= bit_size
;
5367 else if (ada_is_wrapper_field (type
, i
))
5369 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
5370 field_type_p
, byte_offset_p
, bit_offset_p
,
5374 else if (ada_is_variant_part (type
, i
))
5377 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5379 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5381 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
5383 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5384 field_type_p
, byte_offset_p
,
5385 bit_offset_p
, bit_size_p
))
5395 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5396 and search in it assuming it has (class) type TYPE.
5397 If found, return value, else return NULL.
5399 Searches recursively through wrapper fields (e.g., '_parent'). */
5401 static struct value
*
5402 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5406 type
= ada_check_typedef (type
);
5408 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5410 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5412 if (t_field_name
== NULL
)
5415 else if (field_name_match (t_field_name
, name
))
5416 return ada_value_primitive_field (arg
, offset
, i
, type
);
5418 else if (ada_is_wrapper_field (type
, i
))
5420 struct value
*v
= /* Do not let indent join lines here. */
5421 ada_search_struct_field (name
, arg
,
5422 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5423 TYPE_FIELD_TYPE (type
, i
));
5428 else if (ada_is_variant_part (type
, i
))
5431 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5432 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5434 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5436 struct value
*v
= ada_search_struct_field
/* Force line break. */
5438 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5439 TYPE_FIELD_TYPE (field_type
, j
));
5448 /* Given ARG, a value of type (pointer or reference to a)*
5449 structure/union, extract the component named NAME from the ultimate
5450 target structure/union and return it as a value with its
5451 appropriate type. If ARG is a pointer or reference and the field
5452 is not packed, returns a reference to the field, otherwise the
5453 value of the field (an lvalue if ARG is an lvalue).
5455 The routine searches for NAME among all members of the structure itself
5456 and (recursively) among all members of any wrapper members
5459 ERR is a name (for use in error messages) that identifies the class
5460 of entity that ARG is supposed to be. ERR may be null, indicating
5461 that on error, the function simply returns NULL, and does not
5462 throw an error. (FIXME: True only if ARG is a pointer or reference
5466 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5468 struct type
*t
, *t1
;
5472 t1
= t
= ada_check_typedef (value_type (arg
));
5473 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5475 t1
= TYPE_TARGET_TYPE (t
);
5481 error (_("Bad value type in a %s."), err
);
5483 t1
= ada_check_typedef (t1
);
5484 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5486 arg
= coerce_ref (arg
);
5491 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5493 t1
= TYPE_TARGET_TYPE (t
);
5499 error (_("Bad value type in a %s."), err
);
5501 t1
= ada_check_typedef (t1
);
5502 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5504 arg
= value_ind (arg
);
5511 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
5516 error (_("Attempt to extract a component of a value that is not a %s."),
5521 v
= ada_search_struct_field (name
, arg
, 0, t
);
5524 int bit_offset
, bit_size
, byte_offset
;
5525 struct type
*field_type
;
5528 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5529 address
= value_as_address (arg
);
5531 address
= unpack_pointer (t
, VALUE_CONTENTS (arg
));
5533 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
5534 if (find_struct_field (name
, t1
, 0,
5535 &field_type
, &byte_offset
, &bit_offset
,
5540 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5541 arg
= ada_coerce_ref (arg
);
5543 arg
= ada_value_ind (arg
);
5544 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
5545 bit_offset
, bit_size
,
5549 v
= value_from_pointer (lookup_reference_type (field_type
),
5550 address
+ byte_offset
);
5554 if (v
== NULL
&& err
!= NULL
)
5555 error (_("There is no member named %s."), name
);
5560 /* Given a type TYPE, look up the type of the component of type named NAME.
5561 If DISPP is non-null, add its byte displacement from the beginning of a
5562 structure (pointed to by a value) of type TYPE to *DISPP (does not
5563 work for packed fields).
5565 Matches any field whose name has NAME as a prefix, possibly
5568 TYPE can be either a struct or union. If REFOK, TYPE may also
5569 be a (pointer or reference)+ to a struct or union, and the
5570 ultimate target type will be searched.
5572 Looks recursively into variant clauses and parent types.
5574 If NOERR is nonzero, return NULL if NAME is not suitably defined or
5575 TYPE is not a type of the right kind. */
5577 static struct type
*
5578 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
5579 int noerr
, int *dispp
)
5586 if (refok
&& type
!= NULL
)
5589 type
= ada_check_typedef (type
);
5590 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5591 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5593 type
= TYPE_TARGET_TYPE (type
);
5597 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
5598 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
5604 target_terminal_ours ();
5605 gdb_flush (gdb_stdout
);
5607 error (_("Type (null) is not a structure or union type"));
5610 /* XXX: type_sprint */
5611 fprintf_unfiltered (gdb_stderr
, _("Type "));
5612 type_print (type
, "", gdb_stderr
, -1);
5613 error (_(" is not a structure or union type"));
5618 type
= to_static_fixed_type (type
);
5620 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5622 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5626 if (t_field_name
== NULL
)
5629 else if (field_name_match (t_field_name
, name
))
5632 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5633 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5636 else if (ada_is_wrapper_field (type
, i
))
5639 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5644 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5649 else if (ada_is_variant_part (type
, i
))
5652 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5654 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5657 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5662 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5673 target_terminal_ours ();
5674 gdb_flush (gdb_stdout
);
5677 /* XXX: type_sprint */
5678 fprintf_unfiltered (gdb_stderr
, _("Type "));
5679 type_print (type
, "", gdb_stderr
, -1);
5680 error (_(" has no component named <null>"));
5684 /* XXX: type_sprint */
5685 fprintf_unfiltered (gdb_stderr
, _("Type "));
5686 type_print (type
, "", gdb_stderr
, -1);
5687 error (_(" has no component named %s"), name
);
5694 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5695 within a value of type OUTER_TYPE that is stored in GDB at
5696 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5697 numbering from 0) is applicable. Returns -1 if none are. */
5700 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5701 char *outer_valaddr
)
5706 struct type
*discrim_type
;
5707 char *discrim_name
= ada_variant_discrim_name (var_type
);
5708 LONGEST discrim_val
;
5712 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
5713 if (discrim_type
== NULL
)
5715 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5718 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5720 if (ada_is_others_clause (var_type
, i
))
5722 else if (ada_in_variant (discrim_val
, var_type
, i
))
5726 return others_clause
;
5731 /* Dynamic-Sized Records */
5733 /* Strategy: The type ostensibly attached to a value with dynamic size
5734 (i.e., a size that is not statically recorded in the debugging
5735 data) does not accurately reflect the size or layout of the value.
5736 Our strategy is to convert these values to values with accurate,
5737 conventional types that are constructed on the fly. */
5739 /* There is a subtle and tricky problem here. In general, we cannot
5740 determine the size of dynamic records without its data. However,
5741 the 'struct value' data structure, which GDB uses to represent
5742 quantities in the inferior process (the target), requires the size
5743 of the type at the time of its allocation in order to reserve space
5744 for GDB's internal copy of the data. That's why the
5745 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5746 rather than struct value*s.
5748 However, GDB's internal history variables ($1, $2, etc.) are
5749 struct value*s containing internal copies of the data that are not, in
5750 general, the same as the data at their corresponding addresses in
5751 the target. Fortunately, the types we give to these values are all
5752 conventional, fixed-size types (as per the strategy described
5753 above), so that we don't usually have to perform the
5754 'to_fixed_xxx_type' conversions to look at their values.
5755 Unfortunately, there is one exception: if one of the internal
5756 history variables is an array whose elements are unconstrained
5757 records, then we will need to create distinct fixed types for each
5758 element selected. */
5760 /* The upshot of all of this is that many routines take a (type, host
5761 address, target address) triple as arguments to represent a value.
5762 The host address, if non-null, is supposed to contain an internal
5763 copy of the relevant data; otherwise, the program is to consult the
5764 target at the target address. */
5766 /* Assuming that VAL0 represents a pointer value, the result of
5767 dereferencing it. Differs from value_ind in its treatment of
5768 dynamic-sized types. */
5771 ada_value_ind (struct value
*val0
)
5773 struct value
*val
= unwrap_value (value_ind (val0
));
5774 return ada_to_fixed_value (val
);
5777 /* The value resulting from dereferencing any "reference to"
5778 qualifiers on VAL0. */
5780 static struct value
*
5781 ada_coerce_ref (struct value
*val0
)
5783 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
5785 struct value
*val
= val0
;
5786 val
= coerce_ref (val
);
5787 val
= unwrap_value (val
);
5788 return ada_to_fixed_value (val
);
5794 /* Return OFF rounded upward if necessary to a multiple of
5795 ALIGNMENT (a power of 2). */
5798 align_value (unsigned int off
, unsigned int alignment
)
5800 return (off
+ alignment
- 1) & ~(alignment
- 1);
5803 /* Return the bit alignment required for field #F of template type TYPE. */
5806 field_alignment (struct type
*type
, int f
)
5808 const char *name
= TYPE_FIELD_NAME (type
, f
);
5809 int len
= (name
== NULL
) ? 0 : strlen (name
);
5812 if (!isdigit (name
[len
- 1]))
5815 if (isdigit (name
[len
- 2]))
5816 align_offset
= len
- 2;
5818 align_offset
= len
- 1;
5820 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
5821 return TARGET_CHAR_BIT
;
5823 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5826 /* Find a symbol named NAME. Ignores ambiguity. */
5829 ada_find_any_symbol (const char *name
)
5833 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
5834 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5837 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
5841 /* Find a type named NAME. Ignores ambiguity. */
5844 ada_find_any_type (const char *name
)
5846 struct symbol
*sym
= ada_find_any_symbol (name
);
5849 return SYMBOL_TYPE (sym
);
5854 /* Given a symbol NAME and its associated BLOCK, search all symbols
5855 for its ___XR counterpart, which is the ``renaming'' symbol
5856 associated to NAME. Return this symbol if found, return
5860 ada_find_renaming_symbol (const char *name
, struct block
*block
)
5862 const struct symbol
*function_sym
= block_function (block
);
5865 if (function_sym
!= NULL
)
5867 /* If the symbol is defined inside a function, NAME is not fully
5868 qualified. This means we need to prepend the function name
5869 as well as adding the ``___XR'' suffix to build the name of
5870 the associated renaming symbol. */
5871 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
5872 const int function_name_len
= strlen (function_name
);
5873 const int rename_len
= function_name_len
+ 2 /* "__" */
5874 + strlen (name
) + 6 /* "___XR\0" */ ;
5876 /* Library-level functions are a special case, as GNAT adds
5877 a ``_ada_'' prefix to the function name to avoid namespace
5878 pollution. However, the renaming symbol themselves do not
5879 have this prefix, so we need to skip this prefix if present. */
5880 if (function_name_len
> 5 /* "_ada_" */
5881 && strstr (function_name
, "_ada_") == function_name
)
5882 function_name
= function_name
+ 5;
5884 rename
= (char *) alloca (rename_len
* sizeof (char));
5885 sprintf (rename
, "%s__%s___XR", function_name
, name
);
5889 const int rename_len
= strlen (name
) + 6;
5890 rename
= (char *) alloca (rename_len
* sizeof (char));
5891 sprintf (rename
, "%s___XR", name
);
5894 return ada_find_any_symbol (rename
);
5897 /* Because of GNAT encoding conventions, several GDB symbols may match a
5898 given type name. If the type denoted by TYPE0 is to be preferred to
5899 that of TYPE1 for purposes of type printing, return non-zero;
5900 otherwise return 0. */
5903 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5907 else if (type0
== NULL
)
5909 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5911 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5913 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
5915 else if (ada_is_packed_array_type (type0
))
5917 else if (ada_is_array_descriptor_type (type0
)
5918 && !ada_is_array_descriptor_type (type1
))
5920 else if (ada_renaming_type (type0
) != NULL
5921 && ada_renaming_type (type1
) == NULL
)
5926 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5927 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5930 ada_type_name (struct type
*type
)
5934 else if (TYPE_NAME (type
) != NULL
)
5935 return TYPE_NAME (type
);
5937 return TYPE_TAG_NAME (type
);
5940 /* Find a parallel type to TYPE whose name is formed by appending
5941 SUFFIX to the name of TYPE. */
5944 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5947 static size_t name_len
= 0;
5949 char *typename
= ada_type_name (type
);
5951 if (typename
== NULL
)
5954 len
= strlen (typename
);
5956 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5958 strcpy (name
, typename
);
5959 strcpy (name
+ len
, suffix
);
5961 return ada_find_any_type (name
);
5965 /* If TYPE is a variable-size record type, return the corresponding template
5966 type describing its fields. Otherwise, return NULL. */
5968 static struct type
*
5969 dynamic_template_type (struct type
*type
)
5971 type
= ada_check_typedef (type
);
5973 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5974 || ada_type_name (type
) == NULL
)
5978 int len
= strlen (ada_type_name (type
));
5979 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
5982 return ada_find_parallel_type (type
, "___XVE");
5986 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5987 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5990 is_dynamic_field (struct type
*templ_type
, int field_num
)
5992 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5994 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5995 && strstr (name
, "___XVL") != NULL
;
5998 /* The index of the variant field of TYPE, or -1 if TYPE does not
5999 represent a variant record type. */
6002 variant_field_index (struct type
*type
)
6006 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6009 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6011 if (ada_is_variant_part (type
, f
))
6017 /* A record type with no fields. */
6019 static struct type
*
6020 empty_record (struct objfile
*objfile
)
6022 struct type
*type
= alloc_type (objfile
);
6023 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6024 TYPE_NFIELDS (type
) = 0;
6025 TYPE_FIELDS (type
) = NULL
;
6026 TYPE_NAME (type
) = "<empty>";
6027 TYPE_TAG_NAME (type
) = NULL
;
6028 TYPE_FLAGS (type
) = 0;
6029 TYPE_LENGTH (type
) = 0;
6033 /* An ordinary record type (with fixed-length fields) that describes
6034 the value of type TYPE at VALADDR or ADDRESS (see comments at
6035 the beginning of this section) VAL according to GNAT conventions.
6036 DVAL0 should describe the (portion of a) record that contains any
6037 necessary discriminants. It should be NULL if value_type (VAL) is
6038 an outer-level type (i.e., as opposed to a branch of a variant.) A
6039 variant field (unless unchecked) is replaced by a particular branch
6042 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6043 length are not statically known are discarded. As a consequence,
6044 VALADDR, ADDRESS and DVAL0 are ignored.
6046 NOTE: Limitations: For now, we assume that dynamic fields and
6047 variants occupy whole numbers of bytes. However, they need not be
6051 ada_template_to_fixed_record_type_1 (struct type
*type
, char *valaddr
,
6052 CORE_ADDR address
, struct value
*dval0
,
6053 int keep_dynamic_fields
)
6055 struct value
*mark
= value_mark ();
6058 int nfields
, bit_len
;
6061 int fld_bit_len
, bit_incr
;
6064 /* Compute the number of fields in this record type that are going
6065 to be processed: unless keep_dynamic_fields, this includes only
6066 fields whose position and length are static will be processed. */
6067 if (keep_dynamic_fields
)
6068 nfields
= TYPE_NFIELDS (type
);
6072 while (nfields
< TYPE_NFIELDS (type
)
6073 && !ada_is_variant_part (type
, nfields
)
6074 && !is_dynamic_field (type
, nfields
))
6078 rtype
= alloc_type (TYPE_OBJFILE (type
));
6079 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6080 INIT_CPLUS_SPECIFIC (rtype
);
6081 TYPE_NFIELDS (rtype
) = nfields
;
6082 TYPE_FIELDS (rtype
) = (struct field
*)
6083 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6084 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6085 TYPE_NAME (rtype
) = ada_type_name (type
);
6086 TYPE_TAG_NAME (rtype
) = NULL
;
6087 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6093 for (f
= 0; f
< nfields
; f
+= 1)
6095 off
= align_value (off
, field_alignment (type
, f
))
6096 + TYPE_FIELD_BITPOS (type
, f
);
6097 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6098 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6100 if (ada_is_variant_part (type
, f
))
6103 fld_bit_len
= bit_incr
= 0;
6105 else if (is_dynamic_field (type
, f
))
6108 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6112 TYPE_FIELD_TYPE (rtype
, f
) =
6115 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6116 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6117 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6118 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6119 bit_incr
= fld_bit_len
=
6120 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6124 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6125 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6126 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6127 bit_incr
= fld_bit_len
=
6128 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6130 bit_incr
= fld_bit_len
=
6131 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6133 if (off
+ fld_bit_len
> bit_len
)
6134 bit_len
= off
+ fld_bit_len
;
6136 TYPE_LENGTH (rtype
) =
6137 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6140 /* We handle the variant part, if any, at the end because of certain
6141 odd cases in which it is re-ordered so as NOT the last field of
6142 the record. This can happen in the presence of representation
6144 if (variant_field
>= 0)
6146 struct type
*branch_type
;
6148 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6151 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6156 to_fixed_variant_branch_type
6157 (TYPE_FIELD_TYPE (type
, variant_field
),
6158 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6159 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6160 if (branch_type
== NULL
)
6162 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6163 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6164 TYPE_NFIELDS (rtype
) -= 1;
6168 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6169 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6171 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6173 if (off
+ fld_bit_len
> bit_len
)
6174 bit_len
= off
+ fld_bit_len
;
6175 TYPE_LENGTH (rtype
) =
6176 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6180 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6181 should contain the alignment of that record, which should be a strictly
6182 positive value. If null or negative, then something is wrong, most
6183 probably in the debug info. In that case, we don't round up the size
6184 of the resulting type. If this record is not part of another structure,
6185 the current RTYPE length might be good enough for our purposes. */
6186 if (TYPE_LENGTH (type
) <= 0)
6188 if (TYPE_NAME (rtype
))
6189 warning (_("Invalid type size for `%s' detected: %d."),
6190 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6192 warning (_("Invalid type size for <unnamed> detected: %d."),
6193 TYPE_LENGTH (type
));
6197 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6198 TYPE_LENGTH (type
));
6201 value_free_to_mark (mark
);
6202 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6203 error (_("record type with dynamic size is larger than varsize-limit"));
6207 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6210 static struct type
*
6211 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
6212 CORE_ADDR address
, struct value
*dval0
)
6214 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6218 /* An ordinary record type in which ___XVL-convention fields and
6219 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6220 static approximations, containing all possible fields. Uses
6221 no runtime values. Useless for use in values, but that's OK,
6222 since the results are used only for type determinations. Works on both
6223 structs and unions. Representation note: to save space, we memorize
6224 the result of this function in the TYPE_TARGET_TYPE of the
6227 static struct type
*
6228 template_to_static_fixed_type (struct type
*type0
)
6234 if (TYPE_TARGET_TYPE (type0
) != NULL
)
6235 return TYPE_TARGET_TYPE (type0
);
6237 nfields
= TYPE_NFIELDS (type0
);
6240 for (f
= 0; f
< nfields
; f
+= 1)
6242 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
6243 struct type
*new_type
;
6245 if (is_dynamic_field (type0
, f
))
6246 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
6248 new_type
= to_static_fixed_type (field_type
);
6249 if (type
== type0
&& new_type
!= field_type
)
6251 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
6252 TYPE_CODE (type
) = TYPE_CODE (type0
);
6253 INIT_CPLUS_SPECIFIC (type
);
6254 TYPE_NFIELDS (type
) = nfields
;
6255 TYPE_FIELDS (type
) = (struct field
*)
6256 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6257 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
6258 sizeof (struct field
) * nfields
);
6259 TYPE_NAME (type
) = ada_type_name (type0
);
6260 TYPE_TAG_NAME (type
) = NULL
;
6261 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
6262 TYPE_LENGTH (type
) = 0;
6264 TYPE_FIELD_TYPE (type
, f
) = new_type
;
6265 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
6270 /* Given an object of type TYPE whose contents are at VALADDR and
6271 whose address in memory is ADDRESS, returns a revision of TYPE --
6272 a non-dynamic-sized record with a variant part -- in which
6273 the variant part is replaced with the appropriate branch. Looks
6274 for discriminant values in DVAL0, which can be NULL if the record
6275 contains the necessary discriminant values. */
6277 static struct type
*
6278 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6279 CORE_ADDR address
, struct value
*dval0
)
6281 struct value
*mark
= value_mark ();
6284 struct type
*branch_type
;
6285 int nfields
= TYPE_NFIELDS (type
);
6286 int variant_field
= variant_field_index (type
);
6288 if (variant_field
== -1)
6292 dval
= value_from_contents_and_address (type
, valaddr
, address
);
6296 rtype
= alloc_type (TYPE_OBJFILE (type
));
6297 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6298 INIT_CPLUS_SPECIFIC (rtype
);
6299 TYPE_NFIELDS (rtype
) = nfields
;
6300 TYPE_FIELDS (rtype
) =
6301 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6302 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6303 sizeof (struct field
) * nfields
);
6304 TYPE_NAME (rtype
) = ada_type_name (type
);
6305 TYPE_TAG_NAME (rtype
) = NULL
;
6306 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6307 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6309 branch_type
= to_fixed_variant_branch_type
6310 (TYPE_FIELD_TYPE (type
, variant_field
),
6311 cond_offset_host (valaddr
,
6312 TYPE_FIELD_BITPOS (type
, variant_field
)
6314 cond_offset_target (address
,
6315 TYPE_FIELD_BITPOS (type
, variant_field
)
6316 / TARGET_CHAR_BIT
), dval
);
6317 if (branch_type
== NULL
)
6320 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
6321 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6322 TYPE_NFIELDS (rtype
) -= 1;
6326 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6327 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6328 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
6329 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6331 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
6333 value_free_to_mark (mark
);
6337 /* An ordinary record type (with fixed-length fields) that describes
6338 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6339 beginning of this section]. Any necessary discriminants' values
6340 should be in DVAL, a record value; it may be NULL if the object
6341 at ADDR itself contains any necessary discriminant values.
6342 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6343 values from the record are needed. Except in the case that DVAL,
6344 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6345 unchecked) is replaced by a particular branch of the variant.
6347 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6348 is questionable and may be removed. It can arise during the
6349 processing of an unconstrained-array-of-record type where all the
6350 variant branches have exactly the same size. This is because in
6351 such cases, the compiler does not bother to use the XVS convention
6352 when encoding the record. I am currently dubious of this
6353 shortcut and suspect the compiler should be altered. FIXME. */
6355 static struct type
*
6356 to_fixed_record_type (struct type
*type0
, char *valaddr
,
6357 CORE_ADDR address
, struct value
*dval
)
6359 struct type
*templ_type
;
6361 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6364 templ_type
= dynamic_template_type (type0
);
6366 if (templ_type
!= NULL
)
6367 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6368 else if (variant_field_index (type0
) >= 0)
6370 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
6372 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
6377 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
6383 /* An ordinary record type (with fixed-length fields) that describes
6384 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6385 union type. Any necessary discriminants' values should be in DVAL,
6386 a record value. That is, this routine selects the appropriate
6387 branch of the union at ADDR according to the discriminant value
6388 indicated in the union's type name. */
6390 static struct type
*
6391 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6392 CORE_ADDR address
, struct value
*dval
)
6395 struct type
*templ_type
;
6396 struct type
*var_type
;
6398 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6399 var_type
= TYPE_TARGET_TYPE (var_type0
);
6401 var_type
= var_type0
;
6403 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6405 if (templ_type
!= NULL
)
6406 var_type
= templ_type
;
6409 ada_which_variant_applies (var_type
,
6410 value_type (dval
), VALUE_CONTENTS (dval
));
6413 return empty_record (TYPE_OBJFILE (var_type
));
6414 else if (is_dynamic_field (var_type
, which
))
6415 return to_fixed_record_type
6416 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6417 valaddr
, address
, dval
);
6418 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
6420 to_fixed_record_type
6421 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6423 return TYPE_FIELD_TYPE (var_type
, which
);
6426 /* Assuming that TYPE0 is an array type describing the type of a value
6427 at ADDR, and that DVAL describes a record containing any
6428 discriminants used in TYPE0, returns a type for the value that
6429 contains no dynamic components (that is, no components whose sizes
6430 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6431 true, gives an error message if the resulting type's size is over
6434 static struct type
*
6435 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6438 struct type
*index_type_desc
;
6439 struct type
*result
;
6441 if (ada_is_packed_array_type (type0
) /* revisit? */
6442 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
6445 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6446 if (index_type_desc
== NULL
)
6448 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
6449 /* NOTE: elt_type---the fixed version of elt_type0---should never
6450 depend on the contents of the array in properly constructed
6452 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6454 if (elt_type0
== elt_type
)
6457 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6458 elt_type
, TYPE_INDEX_TYPE (type0
));
6463 struct type
*elt_type0
;
6466 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6467 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6469 /* NOTE: result---the fixed version of elt_type0---should never
6470 depend on the contents of the array in properly constructed
6472 result
= ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
);
6473 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6475 struct type
*range_type
=
6476 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6477 dval
, TYPE_OBJFILE (type0
));
6478 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6479 result
, range_type
);
6481 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6482 error (_("array type with dynamic size is larger than varsize-limit"));
6485 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
6490 /* A standard type (containing no dynamically sized components)
6491 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6492 DVAL describes a record containing any discriminants used in TYPE0,
6493 and may be NULL if there are none, or if the object of type TYPE at
6494 ADDRESS or in VALADDR contains these discriminants. */
6497 ada_to_fixed_type (struct type
*type
, char *valaddr
,
6498 CORE_ADDR address
, struct value
*dval
)
6500 type
= ada_check_typedef (type
);
6501 switch (TYPE_CODE (type
))
6505 case TYPE_CODE_STRUCT
:
6507 struct type
*static_type
= to_static_fixed_type (type
);
6508 if (ada_is_tagged_type (static_type
, 0))
6510 struct type
*real_type
=
6511 type_from_tag (value_tag_from_contents_and_address (static_type
,
6514 if (real_type
!= NULL
)
6517 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6519 case TYPE_CODE_ARRAY
:
6520 return to_fixed_array_type (type
, dval
, 1);
6521 case TYPE_CODE_UNION
:
6525 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6529 /* A standard (static-sized) type corresponding as well as possible to
6530 TYPE0, but based on no runtime data. */
6532 static struct type
*
6533 to_static_fixed_type (struct type
*type0
)
6540 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6543 type0
= ada_check_typedef (type0
);
6545 switch (TYPE_CODE (type0
))
6549 case TYPE_CODE_STRUCT
:
6550 type
= dynamic_template_type (type0
);
6552 return template_to_static_fixed_type (type
);
6554 return template_to_static_fixed_type (type0
);
6555 case TYPE_CODE_UNION
:
6556 type
= ada_find_parallel_type (type0
, "___XVU");
6558 return template_to_static_fixed_type (type
);
6560 return template_to_static_fixed_type (type0
);
6564 /* A static approximation of TYPE with all type wrappers removed. */
6566 static struct type
*
6567 static_unwrap_type (struct type
*type
)
6569 if (ada_is_aligner_type (type
))
6571 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
6572 if (ada_type_name (type1
) == NULL
)
6573 TYPE_NAME (type1
) = ada_type_name (type
);
6575 return static_unwrap_type (type1
);
6579 struct type
*raw_real_type
= ada_get_base_type (type
);
6580 if (raw_real_type
== type
)
6583 return to_static_fixed_type (raw_real_type
);
6587 /* In some cases, incomplete and private types require
6588 cross-references that are not resolved as records (for example,
6590 type FooP is access Foo;
6592 type Foo is array ...;
6593 ). In these cases, since there is no mechanism for producing
6594 cross-references to such types, we instead substitute for FooP a
6595 stub enumeration type that is nowhere resolved, and whose tag is
6596 the name of the actual type. Call these types "non-record stubs". */
6598 /* A type equivalent to TYPE that is not a non-record stub, if one
6599 exists, otherwise TYPE. */
6602 ada_check_typedef (struct type
*type
)
6604 CHECK_TYPEDEF (type
);
6605 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6606 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6607 || TYPE_TAG_NAME (type
) == NULL
)
6611 char *name
= TYPE_TAG_NAME (type
);
6612 struct type
*type1
= ada_find_any_type (name
);
6613 return (type1
== NULL
) ? type
: type1
;
6617 /* A value representing the data at VALADDR/ADDRESS as described by
6618 type TYPE0, but with a standard (static-sized) type that correctly
6619 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6620 type, then return VAL0 [this feature is simply to avoid redundant
6621 creation of struct values]. */
6623 static struct value
*
6624 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
6627 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
6628 if (type
== type0
&& val0
!= NULL
)
6631 return value_from_contents_and_address (type
, 0, address
);
6634 /* A value representing VAL, but with a standard (static-sized) type
6635 that correctly describes it. Does not necessarily create a new
6638 static struct value
*
6639 ada_to_fixed_value (struct value
*val
)
6641 return ada_to_fixed_value_create (value_type (val
),
6642 VALUE_ADDRESS (val
) + value_offset (val
),
6646 /* A value representing VAL, but with a standard (static-sized) type
6647 chosen to approximate the real type of VAL as well as possible, but
6648 without consulting any runtime values. For Ada dynamic-sized
6649 types, therefore, the type of the result is likely to be inaccurate. */
6652 ada_to_static_fixed_value (struct value
*val
)
6655 to_static_fixed_type (static_unwrap_type (value_type (val
)));
6656 if (type
== value_type (val
))
6659 return coerce_unspec_val_to_type (val
, type
);
6665 /* Table mapping attribute numbers to names.
6666 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
6668 static const char *attribute_names
[] = {
6686 ada_attribute_name (enum exp_opcode n
)
6688 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
6689 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
6691 return attribute_names
[0];
6694 /* Evaluate the 'POS attribute applied to ARG. */
6697 pos_atr (struct value
*arg
)
6699 struct type
*type
= value_type (arg
);
6701 if (!discrete_type_p (type
))
6702 error (_("'POS only defined on discrete types"));
6704 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6707 LONGEST v
= value_as_long (arg
);
6709 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6711 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6714 error (_("enumeration value is invalid: can't find 'POS"));
6717 return value_as_long (arg
);
6720 static struct value
*
6721 value_pos_atr (struct value
*arg
)
6723 return value_from_longest (builtin_type_int
, pos_atr (arg
));
6726 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6728 static struct value
*
6729 value_val_atr (struct type
*type
, struct value
*arg
)
6731 if (!discrete_type_p (type
))
6732 error (_("'VAL only defined on discrete types"));
6733 if (!integer_type_p (value_type (arg
)))
6734 error (_("'VAL requires integral argument"));
6736 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6738 long pos
= value_as_long (arg
);
6739 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6740 error (_("argument to 'VAL out of range"));
6741 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6744 return value_from_longest (type
, value_as_long (arg
));
6750 /* True if TYPE appears to be an Ada character type.
6751 [At the moment, this is true only for Character and Wide_Character;
6752 It is a heuristic test that could stand improvement]. */
6755 ada_is_character_type (struct type
*type
)
6757 const char *name
= ada_type_name (type
);
6760 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6761 || TYPE_CODE (type
) == TYPE_CODE_INT
6762 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6763 && (strcmp (name
, "character") == 0
6764 || strcmp (name
, "wide_character") == 0
6765 || strcmp (name
, "unsigned char") == 0);
6768 /* True if TYPE appears to be an Ada string type. */
6771 ada_is_string_type (struct type
*type
)
6773 type
= ada_check_typedef (type
);
6775 && TYPE_CODE (type
) != TYPE_CODE_PTR
6776 && (ada_is_simple_array_type (type
)
6777 || ada_is_array_descriptor_type (type
))
6778 && ada_array_arity (type
) == 1)
6780 struct type
*elttype
= ada_array_element_type (type
, 1);
6782 return ada_is_character_type (elttype
);
6789 /* True if TYPE is a struct type introduced by the compiler to force the
6790 alignment of a value. Such types have a single field with a
6791 distinctive name. */
6794 ada_is_aligner_type (struct type
*type
)
6796 type
= ada_check_typedef (type
);
6798 /* If we can find a parallel XVS type, then the XVS type should
6799 be used instead of this type. And hence, this is not an aligner
6801 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
6804 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6805 && TYPE_NFIELDS (type
) == 1
6806 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
6809 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6810 the parallel type. */
6813 ada_get_base_type (struct type
*raw_type
)
6815 struct type
*real_type_namer
;
6816 struct type
*raw_real_type
;
6818 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6821 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6822 if (real_type_namer
== NULL
6823 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6824 || TYPE_NFIELDS (real_type_namer
) != 1)
6827 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6828 if (raw_real_type
== NULL
)
6831 return raw_real_type
;
6834 /* The type of value designated by TYPE, with all aligners removed. */
6837 ada_aligned_type (struct type
*type
)
6839 if (ada_is_aligner_type (type
))
6840 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6842 return ada_get_base_type (type
);
6846 /* The address of the aligned value in an object at address VALADDR
6847 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6850 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6852 if (ada_is_aligner_type (type
))
6853 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6855 TYPE_FIELD_BITPOS (type
,
6856 0) / TARGET_CHAR_BIT
);
6863 /* The printed representation of an enumeration literal with encoded
6864 name NAME. The value is good to the next call of ada_enum_name. */
6866 ada_enum_name (const char *name
)
6868 static char *result
;
6869 static size_t result_len
= 0;
6872 /* First, unqualify the enumeration name:
6873 1. Search for the last '.' character. If we find one, then skip
6874 all the preceeding characters, the unqualified name starts
6875 right after that dot.
6876 2. Otherwise, we may be debugging on a target where the compiler
6877 translates dots into "__". Search forward for double underscores,
6878 but stop searching when we hit an overloading suffix, which is
6879 of the form "__" followed by digits. */
6881 tmp
= strrchr (name
, '.');
6886 while ((tmp
= strstr (name
, "__")) != NULL
)
6888 if (isdigit (tmp
[2]))
6898 if (name
[1] == 'U' || name
[1] == 'W')
6900 if (sscanf (name
+ 2, "%x", &v
) != 1)
6906 GROW_VECT (result
, result_len
, 16);
6907 if (isascii (v
) && isprint (v
))
6908 sprintf (result
, "'%c'", v
);
6909 else if (name
[1] == 'U')
6910 sprintf (result
, "[\"%02x\"]", v
);
6912 sprintf (result
, "[\"%04x\"]", v
);
6918 tmp
= strstr (name
, "__");
6920 tmp
= strstr (name
, "$");
6923 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
6924 strncpy (result
, name
, tmp
- name
);
6925 result
[tmp
- name
] = '\0';
6933 static struct value
*
6934 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6937 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6938 (expect_type
, exp
, pos
, noside
);
6941 /* Evaluate the subexpression of EXP starting at *POS as for
6942 evaluate_type, updating *POS to point just past the evaluated
6945 static struct value
*
6946 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6948 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6949 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6952 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6955 static struct value
*
6956 unwrap_value (struct value
*val
)
6958 struct type
*type
= ada_check_typedef (value_type (val
));
6959 if (ada_is_aligner_type (type
))
6961 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6962 NULL
, "internal structure");
6963 struct type
*val_type
= ada_check_typedef (value_type (v
));
6964 if (ada_type_name (val_type
) == NULL
)
6965 TYPE_NAME (val_type
) = ada_type_name (type
);
6967 return unwrap_value (v
);
6971 struct type
*raw_real_type
=
6972 ada_check_typedef (ada_get_base_type (type
));
6974 if (type
== raw_real_type
)
6978 coerce_unspec_val_to_type
6979 (val
, ada_to_fixed_type (raw_real_type
, 0,
6980 VALUE_ADDRESS (val
) + value_offset (val
),
6985 static struct value
*
6986 cast_to_fixed (struct type
*type
, struct value
*arg
)
6990 if (type
== value_type (arg
))
6992 else if (ada_is_fixed_point_type (value_type (arg
)))
6993 val
= ada_float_to_fixed (type
,
6994 ada_fixed_to_float (value_type (arg
),
6995 value_as_long (arg
)));
6999 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
7000 val
= ada_float_to_fixed (type
, argd
);
7003 return value_from_longest (type
, val
);
7006 static struct value
*
7007 cast_from_fixed_to_double (struct value
*arg
)
7009 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7010 value_as_long (arg
));
7011 return value_from_double (builtin_type_double
, val
);
7014 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7015 return the converted value. */
7017 static struct value
*
7018 coerce_for_assign (struct type
*type
, struct value
*val
)
7020 struct type
*type2
= value_type (val
);
7024 type2
= ada_check_typedef (type2
);
7025 type
= ada_check_typedef (type
);
7027 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7028 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7030 val
= ada_value_ind (val
);
7031 type2
= value_type (val
);
7034 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7035 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7037 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7038 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7039 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7040 error (_("Incompatible types in assignment"));
7046 static struct value
*
7047 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7050 struct type
*type1
, *type2
;
7053 arg1
= coerce_ref (arg1
);
7054 arg2
= coerce_ref (arg2
);
7055 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7056 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7058 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7059 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7060 return value_binop (arg1
, arg2
, op
);
7069 return value_binop (arg1
, arg2
, op
);
7072 v2
= value_as_long (arg2
);
7074 error (_("second operand of %s must not be zero."), op_string (op
));
7076 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7077 return value_binop (arg1
, arg2
, op
);
7079 v1
= value_as_long (arg1
);
7084 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7085 v
+= v
> 0 ? -1 : 1;
7093 /* Should not reach this point. */
7097 val
= allocate_value (type1
);
7098 store_unsigned_integer (VALUE_CONTENTS_RAW (val
),
7099 TYPE_LENGTH (value_type (val
)), v
);
7104 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7106 if (ada_is_direct_array_type (value_type (arg1
))
7107 || ada_is_direct_array_type (value_type (arg2
)))
7109 arg1
= ada_coerce_to_simple_array (arg1
);
7110 arg2
= ada_coerce_to_simple_array (arg2
);
7111 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
7112 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
7113 error (_("Attempt to compare array with non-array"));
7114 /* FIXME: The following works only for types whose
7115 representations use all bits (no padding or undefined bits)
7116 and do not have user-defined equality. */
7118 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
7119 && memcmp (VALUE_CONTENTS (arg1
), VALUE_CONTENTS (arg2
),
7120 TYPE_LENGTH (value_type (arg1
))) == 0;
7122 return value_equal (arg1
, arg2
);
7126 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
7127 int *pos
, enum noside noside
)
7130 int tem
, tem2
, tem3
;
7132 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
7135 struct value
**argvec
;
7139 op
= exp
->elts
[pc
].opcode
;
7146 unwrap_value (evaluate_subexp_standard
7147 (expect_type
, exp
, pos
, noside
));
7151 struct value
*result
;
7153 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
7154 /* The result type will have code OP_STRING, bashed there from
7155 OP_ARRAY. Bash it back. */
7156 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
7157 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
7163 type
= exp
->elts
[pc
+ 1].type
;
7164 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
7165 if (noside
== EVAL_SKIP
)
7167 if (type
!= ada_check_typedef (value_type (arg1
)))
7169 if (ada_is_fixed_point_type (type
))
7170 arg1
= cast_to_fixed (type
, arg1
);
7171 else if (ada_is_fixed_point_type (value_type (arg1
)))
7172 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
7173 else if (VALUE_LVAL (arg1
) == lval_memory
)
7175 /* This is in case of the really obscure (and undocumented,
7176 but apparently expected) case of (Foo) Bar.all, where Bar
7177 is an integer constant and Foo is a dynamic-sized type.
7178 If we don't do this, ARG1 will simply be relabeled with
7180 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7181 return value_zero (to_static_fixed_type (type
), not_lval
);
7183 ada_to_fixed_value_create
7184 (type
, VALUE_ADDRESS (arg1
) + value_offset (arg1
), 0);
7187 arg1
= value_cast (type
, arg1
);
7193 type
= exp
->elts
[pc
+ 1].type
;
7194 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
7197 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7198 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7199 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7201 if (ada_is_fixed_point_type (value_type (arg1
)))
7202 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
7203 else if (ada_is_fixed_point_type (value_type (arg2
)))
7205 (_("Fixed-point values must be assigned to fixed-point variables"));
7207 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
7208 return ada_value_assign (arg1
, arg2
);
7211 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7212 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7213 if (noside
== EVAL_SKIP
)
7215 if ((ada_is_fixed_point_type (value_type (arg1
))
7216 || ada_is_fixed_point_type (value_type (arg2
)))
7217 && value_type (arg1
) != value_type (arg2
))
7218 error (_("Operands of fixed-point addition must have the same type"));
7219 return value_cast (value_type (arg1
), value_add (arg1
, arg2
));
7222 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7223 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7224 if (noside
== EVAL_SKIP
)
7226 if ((ada_is_fixed_point_type (value_type (arg1
))
7227 || ada_is_fixed_point_type (value_type (arg2
)))
7228 && value_type (arg1
) != value_type (arg2
))
7229 error (_("Operands of fixed-point subtraction must have the same type"));
7230 return value_cast (value_type (arg1
), value_sub (arg1
, arg2
));
7234 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7235 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7236 if (noside
== EVAL_SKIP
)
7238 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7239 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7240 return value_zero (value_type (arg1
), not_lval
);
7243 if (ada_is_fixed_point_type (value_type (arg1
)))
7244 arg1
= cast_from_fixed_to_double (arg1
);
7245 if (ada_is_fixed_point_type (value_type (arg2
)))
7246 arg2
= cast_from_fixed_to_double (arg2
);
7247 return ada_value_binop (arg1
, arg2
, op
);
7252 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7253 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7254 if (noside
== EVAL_SKIP
)
7256 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7257 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7258 return value_zero (value_type (arg1
), not_lval
);
7260 return ada_value_binop (arg1
, arg2
, op
);
7263 case BINOP_NOTEQUAL
:
7264 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7265 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7266 if (noside
== EVAL_SKIP
)
7268 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7271 tem
= ada_value_equal (arg1
, arg2
);
7272 if (op
== BINOP_NOTEQUAL
)
7274 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
7277 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7278 if (noside
== EVAL_SKIP
)
7280 else if (ada_is_fixed_point_type (value_type (arg1
)))
7281 return value_cast (value_type (arg1
), value_neg (arg1
));
7283 return value_neg (arg1
);
7287 if (noside
== EVAL_SKIP
)
7292 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
7293 /* Only encountered when an unresolved symbol occurs in a
7294 context other than a function call, in which case, it is
7296 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7297 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
7298 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7302 (to_static_fixed_type
7303 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7309 unwrap_value (evaluate_subexp_standard
7310 (expect_type
, exp
, pos
, noside
));
7311 return ada_to_fixed_value (arg1
);
7317 /* Allocate arg vector, including space for the function to be
7318 called in argvec[0] and a terminating NULL. */
7319 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7321 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
7323 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
7324 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
7325 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7326 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
7329 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7330 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7333 if (noside
== EVAL_SKIP
)
7337 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
7338 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7339 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
7340 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
7341 && VALUE_LVAL (argvec
[0]) == lval_memory
))
7342 argvec
[0] = value_addr (argvec
[0]);
7344 type
= ada_check_typedef (value_type (argvec
[0]));
7345 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7347 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
7349 case TYPE_CODE_FUNC
:
7350 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7352 case TYPE_CODE_ARRAY
:
7354 case TYPE_CODE_STRUCT
:
7355 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7356 argvec
[0] = ada_value_ind (argvec
[0]);
7357 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7360 error (_("cannot subscript or call something of type `%s'"),
7361 ada_type_name (value_type (argvec
[0])));
7366 switch (TYPE_CODE (type
))
7368 case TYPE_CODE_FUNC
:
7369 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7370 return allocate_value (TYPE_TARGET_TYPE (type
));
7371 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7372 case TYPE_CODE_STRUCT
:
7376 arity
= ada_array_arity (type
);
7377 type
= ada_array_element_type (type
, nargs
);
7379 error (_("cannot subscript or call a record"));
7381 error (_("wrong number of subscripts; expecting %d"), arity
);
7382 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7383 return allocate_value (ada_aligned_type (type
));
7385 unwrap_value (ada_value_subscript
7386 (argvec
[0], nargs
, argvec
+ 1));
7388 case TYPE_CODE_ARRAY
:
7389 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7391 type
= ada_array_element_type (type
, nargs
);
7393 error (_("element type of array unknown"));
7395 return allocate_value (ada_aligned_type (type
));
7398 unwrap_value (ada_value_subscript
7399 (ada_coerce_to_simple_array (argvec
[0]),
7400 nargs
, argvec
+ 1));
7401 case TYPE_CODE_PTR
: /* Pointer to array */
7402 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7403 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7405 type
= ada_array_element_type (type
, nargs
);
7407 error (_("element type of array unknown"));
7409 return allocate_value (ada_aligned_type (type
));
7412 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7413 nargs
, argvec
+ 1));
7416 error (_("Attempt to index or call something other than an \
7417 array or function"));
7422 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7423 struct value
*low_bound_val
=
7424 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7425 struct value
*high_bound_val
=
7426 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7429 low_bound_val
= coerce_ref (low_bound_val
);
7430 high_bound_val
= coerce_ref (high_bound_val
);
7431 low_bound
= pos_atr (low_bound_val
);
7432 high_bound
= pos_atr (high_bound_val
);
7434 if (noside
== EVAL_SKIP
)
7437 /* If this is a reference to an aligner type, then remove all
7439 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7440 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
7441 TYPE_TARGET_TYPE (value_type (array
)) =
7442 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
7444 if (ada_is_packed_array_type (value_type (array
)))
7445 error (_("cannot slice a packed array"));
7447 /* If this is a reference to an array or an array lvalue,
7448 convert to a pointer. */
7449 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7450 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
7451 && VALUE_LVAL (array
) == lval_memory
))
7452 array
= value_addr (array
);
7454 if (noside
== EVAL_AVOID_SIDE_EFFECTS
7455 && ada_is_array_descriptor_type (ada_check_typedef
7456 (value_type (array
))))
7457 return empty_array (ada_type_of_array (array
, 0), low_bound
);
7459 array
= ada_coerce_to_simple_array_ptr (array
);
7461 /* If we have more than one level of pointer indirection,
7462 dereference the value until we get only one level. */
7463 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
7464 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
7466 array
= value_ind (array
);
7468 /* Make sure we really do have an array type before going further,
7469 to avoid a SEGV when trying to get the index type or the target
7470 type later down the road if the debug info generated by
7471 the compiler is incorrect or incomplete. */
7472 if (!ada_is_simple_array_type (value_type (array
)))
7473 error (_("cannot take slice of non-array"));
7475 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
7477 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7478 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
7482 struct type
*arr_type0
=
7483 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
7485 return ada_value_slice_ptr (array
, arr_type0
,
7490 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7492 else if (high_bound
< low_bound
)
7493 return empty_array (value_type (array
), low_bound
);
7495 return ada_value_slice (array
, (int) low_bound
, (int) high_bound
);
7500 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7501 type
= exp
->elts
[pc
+ 1].type
;
7503 if (noside
== EVAL_SKIP
)
7506 switch (TYPE_CODE (type
))
7509 lim_warning (_("Membership test incompletely implemented; \
7510 always returns true"));
7511 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
7513 case TYPE_CODE_RANGE
:
7514 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
7515 arg3
= value_from_longest (builtin_type_int
,
7516 TYPE_HIGH_BOUND (type
));
7518 value_from_longest (builtin_type_int
,
7519 (value_less (arg1
, arg3
)
7520 || value_equal (arg1
, arg3
))
7521 && (value_less (arg2
, arg1
)
7522 || value_equal (arg2
, arg1
)));
7525 case BINOP_IN_BOUNDS
:
7527 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7528 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7530 if (noside
== EVAL_SKIP
)
7533 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7534 return value_zero (builtin_type_int
, not_lval
);
7536 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7538 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
7539 error (_("invalid dimension number to 'range"));
7541 arg3
= ada_array_bound (arg2
, tem
, 1);
7542 arg2
= ada_array_bound (arg2
, tem
, 0);
7545 value_from_longest (builtin_type_int
,
7546 (value_less (arg1
, arg3
)
7547 || value_equal (arg1
, arg3
))
7548 && (value_less (arg2
, arg1
)
7549 || value_equal (arg2
, arg1
)));
7551 case TERNOP_IN_RANGE
:
7552 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7553 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7554 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7556 if (noside
== EVAL_SKIP
)
7560 value_from_longest (builtin_type_int
,
7561 (value_less (arg1
, arg3
)
7562 || value_equal (arg1
, arg3
))
7563 && (value_less (arg2
, arg1
)
7564 || value_equal (arg2
, arg1
)));
7570 struct type
*type_arg
;
7571 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
7573 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7575 type_arg
= exp
->elts
[pc
+ 2].type
;
7579 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7583 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
7584 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
7585 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
7588 if (noside
== EVAL_SKIP
)
7591 if (type_arg
== NULL
)
7593 arg1
= ada_coerce_ref (arg1
);
7595 if (ada_is_packed_array_type (value_type (arg1
)))
7596 arg1
= ada_coerce_to_simple_array (arg1
);
7598 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
7599 error (_("invalid dimension number to '%s"),
7600 ada_attribute_name (op
));
7602 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7604 type
= ada_index_type (value_type (arg1
), tem
);
7607 (_("attempt to take bound of something that is not an array"));
7608 return allocate_value (type
);
7613 default: /* Should never happen. */
7614 error (_("unexpected attribute encountered"));
7616 return ada_array_bound (arg1
, tem
, 0);
7618 return ada_array_bound (arg1
, tem
, 1);
7620 return ada_array_length (arg1
, tem
);
7623 else if (discrete_type_p (type_arg
))
7625 struct type
*range_type
;
7626 char *name
= ada_type_name (type_arg
);
7628 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
7630 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
7631 if (range_type
== NULL
)
7632 range_type
= type_arg
;
7636 error (_("unexpected attribute encountered"));
7638 return discrete_type_low_bound (range_type
);
7640 return discrete_type_high_bound (range_type
);
7642 error (_("the 'length attribute applies only to array types"));
7645 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
7646 error (_("unimplemented type attribute"));
7651 if (ada_is_packed_array_type (type_arg
))
7652 type_arg
= decode_packed_array_type (type_arg
);
7654 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
7655 error (_("invalid dimension number to '%s"),
7656 ada_attribute_name (op
));
7658 type
= ada_index_type (type_arg
, tem
);
7661 (_("attempt to take bound of something that is not an array"));
7662 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7663 return allocate_value (type
);
7668 error (_("unexpected attribute encountered"));
7670 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7671 return value_from_longest (type
, low
);
7673 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
7674 return value_from_longest (type
, high
);
7676 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7677 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
7678 return value_from_longest (type
, high
- low
+ 1);
7684 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7685 if (noside
== EVAL_SKIP
)
7688 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7689 return value_zero (ada_tag_type (arg1
), not_lval
);
7691 return ada_value_tag (arg1
);
7695 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7696 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7697 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7698 if (noside
== EVAL_SKIP
)
7700 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7701 return value_zero (value_type (arg1
), not_lval
);
7703 return value_binop (arg1
, arg2
,
7704 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
7706 case OP_ATR_MODULUS
:
7708 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
7709 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7711 if (noside
== EVAL_SKIP
)
7714 if (!ada_is_modular_type (type_arg
))
7715 error (_("'modulus must be applied to modular type"));
7717 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
7718 ada_modulus (type_arg
));
7723 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7724 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7725 if (noside
== EVAL_SKIP
)
7727 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7728 return value_zero (builtin_type_int
, not_lval
);
7730 return value_pos_atr (arg1
);
7733 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7734 if (noside
== EVAL_SKIP
)
7736 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7737 return value_zero (builtin_type_int
, not_lval
);
7739 return value_from_longest (builtin_type_int
,
7741 * TYPE_LENGTH (value_type (arg1
)));
7744 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7745 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7746 type
= exp
->elts
[pc
+ 2].type
;
7747 if (noside
== EVAL_SKIP
)
7749 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7750 return value_zero (type
, not_lval
);
7752 return value_val_atr (type
, arg1
);
7755 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7756 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7757 if (noside
== EVAL_SKIP
)
7759 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7760 return value_zero (value_type (arg1
), not_lval
);
7762 return value_binop (arg1
, arg2
, op
);
7765 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7766 if (noside
== EVAL_SKIP
)
7772 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7773 if (noside
== EVAL_SKIP
)
7775 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
7776 return value_neg (arg1
);
7781 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7782 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
7783 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7784 if (noside
== EVAL_SKIP
)
7786 type
= ada_check_typedef (value_type (arg1
));
7787 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7789 if (ada_is_array_descriptor_type (type
))
7790 /* GDB allows dereferencing GNAT array descriptors. */
7792 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7793 if (arrType
== NULL
)
7794 error (_("Attempt to dereference null array pointer."));
7795 return value_at_lazy (arrType
, 0);
7797 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7798 || TYPE_CODE (type
) == TYPE_CODE_REF
7799 /* In C you can dereference an array to get the 1st elt. */
7800 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7802 type
= to_static_fixed_type
7804 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
7806 return value_zero (type
, lval_memory
);
7808 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7809 /* GDB allows dereferencing an int. */
7810 return value_zero (builtin_type_int
, lval_memory
);
7812 error (_("Attempt to take contents of a non-pointer value."));
7814 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
7815 type
= ada_check_typedef (value_type (arg1
));
7817 if (ada_is_array_descriptor_type (type
))
7818 /* GDB allows dereferencing GNAT array descriptors. */
7819 return ada_coerce_to_simple_array (arg1
);
7821 return ada_value_ind (arg1
);
7823 case STRUCTOP_STRUCT
:
7824 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7825 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7826 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7827 if (noside
== EVAL_SKIP
)
7829 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7831 struct type
*type1
= value_type (arg1
);
7832 if (ada_is_tagged_type (type1
, 1))
7834 type
= ada_lookup_struct_elt_type (type1
,
7835 &exp
->elts
[pc
+ 2].string
,
7838 /* In this case, we assume that the field COULD exist
7839 in some extension of the type. Return an object of
7840 "type" void, which will match any formal
7841 (see ada_type_match). */
7842 return value_zero (builtin_type_void
, lval_memory
);
7846 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
7849 return value_zero (ada_aligned_type (type
), lval_memory
);
7853 ada_to_fixed_value (unwrap_value
7854 (ada_value_struct_elt
7855 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
7857 /* The value is not supposed to be used. This is here to make it
7858 easier to accommodate expressions that contain types. */
7860 if (noside
== EVAL_SKIP
)
7862 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7863 return allocate_value (builtin_type_void
);
7865 error (_("Attempt to use a type name as an expression"));
7869 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7875 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7876 type name that encodes the 'small and 'delta information.
7877 Otherwise, return NULL. */
7880 fixed_type_info (struct type
*type
)
7882 const char *name
= ada_type_name (type
);
7883 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7885 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7887 const char *tail
= strstr (name
, "___XF_");
7893 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7894 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7899 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7902 ada_is_fixed_point_type (struct type
*type
)
7904 return fixed_type_info (type
) != NULL
;
7907 /* Return non-zero iff TYPE represents a System.Address type. */
7910 ada_is_system_address_type (struct type
*type
)
7912 return (TYPE_NAME (type
)
7913 && strcmp (TYPE_NAME (type
), "system__address") == 0);
7916 /* Assuming that TYPE is the representation of an Ada fixed-point
7917 type, return its delta, or -1 if the type is malformed and the
7918 delta cannot be determined. */
7921 ada_delta (struct type
*type
)
7923 const char *encoding
= fixed_type_info (type
);
7926 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7929 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7932 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7933 factor ('SMALL value) associated with the type. */
7936 scaling_factor (struct type
*type
)
7938 const char *encoding
= fixed_type_info (type
);
7939 unsigned long num0
, den0
, num1
, den1
;
7942 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7947 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7949 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7953 /* Assuming that X is the representation of a value of fixed-point
7954 type TYPE, return its floating-point equivalent. */
7957 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7959 return (DOUBLEST
) x
*scaling_factor (type
);
7962 /* The representation of a fixed-point value of type TYPE
7963 corresponding to the value X. */
7966 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7968 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7972 /* VAX floating formats */
7974 /* Non-zero iff TYPE represents one of the special VAX floating-point
7978 ada_is_vax_floating_type (struct type
*type
)
7981 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7984 && (TYPE_CODE (type
) == TYPE_CODE_INT
7985 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7986 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
7989 /* The type of special VAX floating-point type this is, assuming
7990 ada_is_vax_floating_point. */
7993 ada_vax_float_type_suffix (struct type
*type
)
7995 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7998 /* A value representing the special debugging function that outputs
7999 VAX floating-point values of the type represented by TYPE. Assumes
8000 ada_is_vax_floating_type (TYPE). */
8003 ada_vax_float_print_function (struct type
*type
)
8005 switch (ada_vax_float_type_suffix (type
))
8008 return get_var_value ("DEBUG_STRING_F", 0);
8010 return get_var_value ("DEBUG_STRING_D", 0);
8012 return get_var_value ("DEBUG_STRING_G", 0);
8014 error (_("invalid VAX floating-point type"));
8021 /* Scan STR beginning at position K for a discriminant name, and
8022 return the value of that discriminant field of DVAL in *PX. If
8023 PNEW_K is not null, put the position of the character beyond the
8024 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8025 not alter *PX and *PNEW_K if unsuccessful. */
8028 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
8031 static char *bound_buffer
= NULL
;
8032 static size_t bound_buffer_len
= 0;
8035 struct value
*bound_val
;
8037 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
8040 pend
= strstr (str
+ k
, "__");
8044 k
+= strlen (bound
);
8048 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
8049 bound
= bound_buffer
;
8050 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
8051 bound
[pend
- (str
+ k
)] = '\0';
8055 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
8056 if (bound_val
== NULL
)
8059 *px
= value_as_long (bound_val
);
8065 /* Value of variable named NAME in the current environment. If
8066 no such variable found, then if ERR_MSG is null, returns 0, and
8067 otherwise causes an error with message ERR_MSG. */
8069 static struct value
*
8070 get_var_value (char *name
, char *err_msg
)
8072 struct ada_symbol_info
*syms
;
8075 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
8080 if (err_msg
== NULL
)
8083 error ("%s", err_msg
);
8086 return value_of_variable (syms
[0].sym
, syms
[0].block
);
8089 /* Value of integer variable named NAME in the current environment. If
8090 no such variable found, returns 0, and sets *FLAG to 0. If
8091 successful, sets *FLAG to 1. */
8094 get_int_var_value (char *name
, int *flag
)
8096 struct value
*var_val
= get_var_value (name
, 0);
8108 return value_as_long (var_val
);
8113 /* Return a range type whose base type is that of the range type named
8114 NAME in the current environment, and whose bounds are calculated
8115 from NAME according to the GNAT range encoding conventions.
8116 Extract discriminant values, if needed, from DVAL. If a new type
8117 must be created, allocate in OBJFILE's space. The bounds
8118 information, in general, is encoded in NAME, the base type given in
8119 the named range type. */
8121 static struct type
*
8122 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
8124 struct type
*raw_type
= ada_find_any_type (name
);
8125 struct type
*base_type
;
8128 if (raw_type
== NULL
)
8129 base_type
= builtin_type_int
;
8130 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
8131 base_type
= TYPE_TARGET_TYPE (raw_type
);
8133 base_type
= raw_type
;
8135 subtype_info
= strstr (name
, "___XD");
8136 if (subtype_info
== NULL
)
8140 static char *name_buf
= NULL
;
8141 static size_t name_len
= 0;
8142 int prefix_len
= subtype_info
- name
;
8148 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
8149 strncpy (name_buf
, name
, prefix_len
);
8150 name_buf
[prefix_len
] = '\0';
8153 bounds_str
= strchr (subtype_info
, '_');
8156 if (*subtype_info
== 'L')
8158 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
8159 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
8161 if (bounds_str
[n
] == '_')
8163 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
8170 strcpy (name_buf
+ prefix_len
, "___L");
8171 L
= get_int_var_value (name_buf
, &ok
);
8174 lim_warning (_("Unknown lower bound, using 1."));
8179 if (*subtype_info
== 'U')
8181 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
8182 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
8188 strcpy (name_buf
+ prefix_len
, "___U");
8189 U
= get_int_var_value (name_buf
, &ok
);
8192 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
8197 if (objfile
== NULL
)
8198 objfile
= TYPE_OBJFILE (base_type
);
8199 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
8200 TYPE_NAME (type
) = name
;
8205 /* True iff NAME is the name of a range type. */
8208 ada_is_range_type_name (const char *name
)
8210 return (name
!= NULL
&& strstr (name
, "___XD"));
8216 /* True iff TYPE is an Ada modular type. */
8219 ada_is_modular_type (struct type
*type
)
8221 struct type
*subranged_type
= base_type (type
);
8223 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
8224 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
8225 && TYPE_UNSIGNED (subranged_type
));
8228 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8231 ada_modulus (struct type
* type
)
8233 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
8237 /* Information about operators given special treatment in functions
8239 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
8241 #define ADA_OPERATORS \
8242 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
8243 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
8244 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
8245 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
8246 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
8247 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
8248 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
8249 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
8250 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
8251 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
8252 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
8253 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
8254 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
8255 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
8256 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
8257 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
8260 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
8262 switch (exp
->elts
[pc
- 1].opcode
)
8265 operator_length_standard (exp
, pc
, oplenp
, argsp
);
8268 #define OP_DEFN(op, len, args, binop) \
8269 case op: *oplenp = len; *argsp = args; break;
8276 ada_op_name (enum exp_opcode opcode
)
8281 return op_name_standard (opcode
);
8282 #define OP_DEFN(op, len, args, binop) case op: return #op;
8288 /* As for operator_length, but assumes PC is pointing at the first
8289 element of the operator, and gives meaningful results only for the
8290 Ada-specific operators. */
8293 ada_forward_operator_length (struct expression
*exp
, int pc
,
8294 int *oplenp
, int *argsp
)
8296 switch (exp
->elts
[pc
].opcode
)
8299 *oplenp
= *argsp
= 0;
8301 #define OP_DEFN(op, len, args, binop) \
8302 case op: *oplenp = len; *argsp = args; break;
8309 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
8311 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
8316 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
8320 /* Ada attributes ('Foo). */
8327 case OP_ATR_MODULUS
:
8336 /* XXX: gdb_sprint_host_address, type_sprint */
8337 fprintf_filtered (stream
, _("Type @"));
8338 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
8339 fprintf_filtered (stream
, " (");
8340 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
8341 fprintf_filtered (stream
, ")");
8343 case BINOP_IN_BOUNDS
:
8344 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
8346 case TERNOP_IN_RANGE
:
8350 return dump_subexp_body_standard (exp
, stream
, elt
);
8354 for (i
= 0; i
< nargs
; i
+= 1)
8355 elt
= dump_subexp (exp
, stream
, elt
);
8360 /* The Ada extension of print_subexp (q.v.). */
8363 ada_print_subexp (struct expression
*exp
, int *pos
,
8364 struct ui_file
*stream
, enum precedence prec
)
8368 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
8370 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8375 print_subexp_standard (exp
, pos
, stream
, prec
);
8380 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
8383 case BINOP_IN_BOUNDS
:
8384 /* XXX: sprint_subexp */
8386 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8387 fputs_filtered (" in ", stream
);
8388 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8389 fputs_filtered ("'range", stream
);
8390 if (exp
->elts
[pc
+ 1].longconst
> 1)
8391 fprintf_filtered (stream
, "(%ld)",
8392 (long) exp
->elts
[pc
+ 1].longconst
);
8395 case TERNOP_IN_RANGE
:
8397 if (prec
>= PREC_EQUAL
)
8398 fputs_filtered ("(", stream
);
8399 /* XXX: sprint_subexp */
8400 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8401 fputs_filtered (" in ", stream
);
8402 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8403 fputs_filtered (" .. ", stream
);
8404 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8405 if (prec
>= PREC_EQUAL
)
8406 fputs_filtered (")", stream
);
8415 case OP_ATR_MODULUS
:
8421 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8423 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
8424 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
8428 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8429 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
8433 for (tem
= 1; tem
< nargs
; tem
+= 1)
8435 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
8436 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
8438 fputs_filtered (")", stream
);
8444 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
8445 fputs_filtered ("'(", stream
);
8446 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
8447 fputs_filtered (")", stream
);
8452 /* XXX: sprint_subexp */
8453 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8454 fputs_filtered (" in ", stream
);
8455 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
8460 /* Table mapping opcodes into strings for printing operators
8461 and precedences of the operators. */
8463 static const struct op_print ada_op_print_tab
[] = {
8464 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
8465 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
8466 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
8467 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
8468 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
8469 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
8470 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
8471 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
8472 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
8473 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
8474 {">", BINOP_GTR
, PREC_ORDER
, 0},
8475 {"<", BINOP_LESS
, PREC_ORDER
, 0},
8476 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
8477 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
8478 {"+", BINOP_ADD
, PREC_ADD
, 0},
8479 {"-", BINOP_SUB
, PREC_ADD
, 0},
8480 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8481 {"*", BINOP_MUL
, PREC_MUL
, 0},
8482 {"/", BINOP_DIV
, PREC_MUL
, 0},
8483 {"rem", BINOP_REM
, PREC_MUL
, 0},
8484 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8485 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8486 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8487 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8488 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8489 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8490 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8491 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8492 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
8493 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
8494 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
8498 /* Fundamental Ada Types */
8500 /* Create a fundamental Ada type using default reasonable for the current
8503 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8504 define fundamental types such as "int" or "double". Others (stabs or
8505 DWARF version 2, etc) do define fundamental types. For the formats which
8506 don't provide fundamental types, gdb can create such types using this
8509 FIXME: Some compilers distinguish explicitly signed integral types
8510 (signed short, signed int, signed long) from "regular" integral types
8511 (short, int, long) in the debugging information. There is some dis-
8512 agreement as to how useful this feature is. In particular, gcc does
8513 not support this. Also, only some debugging formats allow the
8514 distinction to be passed on to a debugger. For now, we always just
8515 use "short", "int", or "long" as the type name, for both the implicit
8516 and explicitly signed types. This also makes life easier for the
8517 gdb test suite since we don't have to account for the differences
8518 in output depending upon what the compiler and debugging format
8519 support. We will probably have to re-examine the issue when gdb
8520 starts taking it's fundamental type information directly from the
8521 debugging information supplied by the compiler. fnf@cygnus.com */
8523 static struct type
*
8524 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8526 struct type
*type
= NULL
;
8531 /* FIXME: For now, if we are asked to produce a type not in this
8532 language, create the equivalent of a C integer type with the
8533 name "<?type?>". When all the dust settles from the type
8534 reconstruction work, this should probably become an error. */
8535 type
= init_type (TYPE_CODE_INT
,
8536 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8537 0, "<?type?>", objfile
);
8538 warning (_("internal error: no Ada fundamental type %d"), typeid);
8541 type
= init_type (TYPE_CODE_VOID
,
8542 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8543 0, "void", objfile
);
8546 type
= init_type (TYPE_CODE_INT
,
8547 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8548 0, "character", objfile
);
8550 case FT_SIGNED_CHAR
:
8551 type
= init_type (TYPE_CODE_INT
,
8552 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8553 0, "signed char", objfile
);
8555 case FT_UNSIGNED_CHAR
:
8556 type
= init_type (TYPE_CODE_INT
,
8557 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8558 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8561 type
= init_type (TYPE_CODE_INT
,
8562 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8563 0, "short_integer", objfile
);
8565 case FT_SIGNED_SHORT
:
8566 type
= init_type (TYPE_CODE_INT
,
8567 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8568 0, "short_integer", objfile
);
8570 case FT_UNSIGNED_SHORT
:
8571 type
= init_type (TYPE_CODE_INT
,
8572 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8573 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8576 type
= init_type (TYPE_CODE_INT
,
8577 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8578 0, "integer", objfile
);
8580 case FT_SIGNED_INTEGER
:
8581 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/
8583 0, "integer", objfile
); /* FIXME -fnf */
8585 case FT_UNSIGNED_INTEGER
:
8586 type
= init_type (TYPE_CODE_INT
,
8587 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8588 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8591 type
= init_type (TYPE_CODE_INT
,
8592 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8593 0, "long_integer", objfile
);
8595 case FT_SIGNED_LONG
:
8596 type
= init_type (TYPE_CODE_INT
,
8597 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8598 0, "long_integer", objfile
);
8600 case FT_UNSIGNED_LONG
:
8601 type
= init_type (TYPE_CODE_INT
,
8602 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8603 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8606 type
= init_type (TYPE_CODE_INT
,
8607 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8608 0, "long_long_integer", objfile
);
8610 case FT_SIGNED_LONG_LONG
:
8611 type
= init_type (TYPE_CODE_INT
,
8612 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8613 0, "long_long_integer", objfile
);
8615 case FT_UNSIGNED_LONG_LONG
:
8616 type
= init_type (TYPE_CODE_INT
,
8617 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8618 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8621 type
= init_type (TYPE_CODE_FLT
,
8622 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8623 0, "float", objfile
);
8625 case FT_DBL_PREC_FLOAT
:
8626 type
= init_type (TYPE_CODE_FLT
,
8627 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8628 0, "long_float", objfile
);
8630 case FT_EXT_PREC_FLOAT
:
8631 type
= init_type (TYPE_CODE_FLT
,
8632 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8633 0, "long_long_float", objfile
);
8639 enum ada_primitive_types
{
8640 ada_primitive_type_int
,
8641 ada_primitive_type_long
,
8642 ada_primitive_type_short
,
8643 ada_primitive_type_char
,
8644 ada_primitive_type_float
,
8645 ada_primitive_type_double
,
8646 ada_primitive_type_void
,
8647 ada_primitive_type_long_long
,
8648 ada_primitive_type_long_double
,
8649 ada_primitive_type_natural
,
8650 ada_primitive_type_positive
,
8651 ada_primitive_type_system_address
,
8652 nr_ada_primitive_types
8656 ada_language_arch_info (struct gdbarch
*current_gdbarch
,
8657 struct language_arch_info
*lai
)
8659 const struct builtin_type
*builtin
= builtin_type (current_gdbarch
);
8660 lai
->primitive_type_vector
8661 = GDBARCH_OBSTACK_CALLOC (current_gdbarch
, nr_ada_primitive_types
+ 1,
8663 lai
->primitive_type_vector
[ada_primitive_type_int
] =
8664 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8665 0, "integer", (struct objfile
*) NULL
);
8666 lai
->primitive_type_vector
[ada_primitive_type_long
] =
8667 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8668 0, "long_integer", (struct objfile
*) NULL
);
8669 lai
->primitive_type_vector
[ada_primitive_type_short
] =
8670 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8671 0, "short_integer", (struct objfile
*) NULL
);
8672 lai
->string_char_type
=
8673 lai
->primitive_type_vector
[ada_primitive_type_char
] =
8674 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8675 0, "character", (struct objfile
*) NULL
);
8676 lai
->primitive_type_vector
[ada_primitive_type_float
] =
8677 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8678 0, "float", (struct objfile
*) NULL
);
8679 lai
->primitive_type_vector
[ada_primitive_type_double
] =
8680 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8681 0, "long_float", (struct objfile
*) NULL
);
8682 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
8683 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8684 0, "long_long_integer", (struct objfile
*) NULL
);
8685 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
8686 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8687 0, "long_long_float", (struct objfile
*) NULL
);
8688 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
8689 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8690 0, "natural", (struct objfile
*) NULL
);
8691 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
8692 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8693 0, "positive", (struct objfile
*) NULL
);
8694 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
8696 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
8697 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8698 (struct objfile
*) NULL
));
8699 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
8700 = "system__address";
8703 /* Language vector */
8705 /* Not really used, but needed in the ada_language_defn. */
8708 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8710 ada_emit_char (c
, stream
, quoter
, 1);
8716 warnings_issued
= 0;
8717 return ada_parse ();
8720 static const struct exp_descriptor ada_exp_descriptor
= {
8722 ada_operator_length
,
8724 ada_dump_subexp_body
,
8728 const struct language_defn ada_language_defn
= {
8729 "ada", /* Language name */
8734 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8735 that's not quite what this means. */
8737 &ada_exp_descriptor
,
8741 ada_printchar
, /* Print a character constant */
8742 ada_printstr
, /* Function to print string constant */
8743 emit_char
, /* Function to print single char (not used) */
8744 ada_create_fundamental_type
, /* Create fundamental type in this language */
8745 ada_print_type
, /* Print a type using appropriate syntax */
8746 ada_val_print
, /* Print a value using appropriate syntax */
8747 ada_value_print
, /* Print a top-level value */
8748 NULL
, /* Language specific skip_trampoline */
8749 NULL
, /* value_of_this */
8750 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
8751 basic_lookup_transparent_type
, /* lookup_transparent_type */
8752 ada_la_decode
, /* Language specific symbol demangler */
8753 NULL
, /* Language specific class_name_from_physname */
8754 ada_op_print_tab
, /* expression operators for printing */
8755 0, /* c-style arrays */
8756 1, /* String lower bound */
8758 ada_get_gdb_completer_word_break_characters
,
8759 ada_language_arch_info
,
8764 _initialize_ada_language (void)
8766 add_language (&ada_language_defn
);
8768 varsize_limit
= 65536;
8770 obstack_init (&symbol_list_obstack
);
8772 decoded_names_store
= htab_create_alloc
8773 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
8774 NULL
, xcalloc
, xfree
);