1 /* Ada language support routines for GDB, the GNU debugger. Copyright
3 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004, 2005 Free
4 Software Foundation, Inc.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
25 #include "gdb_string.h"
29 #include "gdb_regex.h"
34 #include "expression.h"
35 #include "parser-defs.h"
41 #include "breakpoint.h"
44 #include "gdb_obstack.h"
46 #include "completer.h"
53 #include "dictionary.h"
54 #include "exceptions.h"
56 #ifndef ADA_RETAIN_DOTS
57 #define ADA_RETAIN_DOTS 0
60 /* Define whether or not the C operator '/' truncates towards zero for
61 differently signed operands (truncation direction is undefined in C).
62 Copied from valarith.c. */
64 #ifndef TRUNCATION_TOWARDS_ZERO
65 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 static void extract_string (CORE_ADDR addr
, char *buf
);
71 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
73 static void modify_general_field (char *, LONGEST
, int, int);
75 static struct type
*desc_base_type (struct type
*);
77 static struct type
*desc_bounds_type (struct type
*);
79 static struct value
*desc_bounds (struct value
*);
81 static int fat_pntr_bounds_bitpos (struct type
*);
83 static int fat_pntr_bounds_bitsize (struct type
*);
85 static struct type
*desc_data_type (struct type
*);
87 static struct value
*desc_data (struct value
*);
89 static int fat_pntr_data_bitpos (struct type
*);
91 static int fat_pntr_data_bitsize (struct type
*);
93 static struct value
*desc_one_bound (struct value
*, int, int);
95 static int desc_bound_bitpos (struct type
*, int, int);
97 static int desc_bound_bitsize (struct type
*, int, int);
99 static struct type
*desc_index_type (struct type
*, int);
101 static int desc_arity (struct type
*);
103 static int ada_type_match (struct type
*, struct type
*, int);
105 static int ada_args_match (struct symbol
*, struct value
**, int);
107 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
109 static struct value
*convert_actual (struct value
*, struct type
*,
112 static struct value
*make_array_descriptor (struct type
*, struct value
*,
115 static void ada_add_block_symbols (struct obstack
*,
116 struct block
*, const char *,
117 domain_enum
, struct objfile
*,
118 struct symtab
*, int);
120 static int is_nonfunction (struct ada_symbol_info
*, int);
122 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
123 struct block
*, struct symtab
*);
125 static int num_defns_collected (struct obstack
*);
127 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
129 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
130 *, const char *, int,
133 static struct symtab
*symtab_for_sym (struct symbol
*);
135 static struct value
*resolve_subexp (struct expression
**, int *, int,
138 static void replace_operator_with_call (struct expression
**, int, int, int,
139 struct symbol
*, struct block
*);
141 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
143 static char *ada_op_name (enum exp_opcode
);
145 static const char *ada_decoded_op_name (enum exp_opcode
);
147 static int numeric_type_p (struct type
*);
149 static int integer_type_p (struct type
*);
151 static int scalar_type_p (struct type
*);
153 static int discrete_type_p (struct type
*);
155 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
158 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
161 static struct value
*evaluate_subexp_type (struct expression
*, int *);
163 static int is_dynamic_field (struct type
*, int);
165 static struct type
*to_fixed_variant_branch_type (struct type
*,
167 CORE_ADDR
, struct value
*);
169 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
171 static struct type
*to_fixed_range_type (char *, struct value
*,
174 static struct type
*to_static_fixed_type (struct type
*);
176 static struct value
*unwrap_value (struct value
*);
178 static struct type
*packed_array_type (struct type
*, long *);
180 static struct type
*decode_packed_array_type (struct type
*);
182 static struct value
*decode_packed_array (struct value
*);
184 static struct value
*value_subscript_packed (struct value
*, int,
187 static struct value
*coerce_unspec_val_to_type (struct value
*,
190 static struct value
*get_var_value (char *, char *);
192 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
194 static int equiv_types (struct type
*, struct type
*);
196 static int is_name_suffix (const char *);
198 static int wild_match (const char *, int, const char *);
200 static struct value
*ada_coerce_ref (struct value
*);
202 static LONGEST
pos_atr (struct value
*);
204 static struct value
*value_pos_atr (struct value
*);
206 static struct value
*value_val_atr (struct type
*, struct value
*);
208 static struct symbol
*standard_lookup (const char *, const struct block
*,
211 static struct value
*ada_search_struct_field (char *, struct value
*, int,
214 static struct value
*ada_value_primitive_field (struct value
*, int, int,
217 static int find_struct_field (char *, struct type
*, int,
218 struct type
**, int *, int *, int *);
220 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
223 static struct value
*ada_to_fixed_value (struct value
*);
225 static int ada_resolve_function (struct ada_symbol_info
*, int,
226 struct value
**, int, const char *,
229 static struct value
*ada_coerce_to_simple_array (struct value
*);
231 static int ada_is_direct_array_type (struct type
*);
233 static void ada_language_arch_info (struct gdbarch
*,
234 struct language_arch_info
*);
236 static void check_size (const struct type
*);
240 /* Maximum-sized dynamic type. */
241 static unsigned int varsize_limit
;
243 /* FIXME: brobecker/2003-09-17: No longer a const because it is
244 returned by a function that does not return a const char *. */
245 static char *ada_completer_word_break_characters
=
247 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
249 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
252 /* The name of the symbol to use to get the name of the main subprogram. */
253 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
254 = "__gnat_ada_main_program_name";
256 /* The name of the runtime function called when an exception is raised. */
257 static const char raise_sym_name
[] = "__gnat_raise_nodefer_with_msg";
259 /* The name of the runtime function called when an unhandled exception
261 static const char raise_unhandled_sym_name
[] = "__gnat_unhandled_exception";
263 /* The name of the runtime function called when an assert failure is
265 static const char raise_assert_sym_name
[] =
266 "system__assertions__raise_assert_failure";
268 /* When GDB stops on an unhandled exception, GDB will go up the stack until
269 if finds a frame corresponding to this function, in order to extract the
270 name of the exception that has been raised from one of the parameters. */
271 static const char process_raise_exception_name
[] =
272 "ada__exceptions__process_raise_exception";
274 /* A string that reflects the longest exception expression rewrite,
275 aside from the exception name. */
276 static const char longest_exception_template
[] =
277 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
279 /* Limit on the number of warnings to raise per expression evaluation. */
280 static int warning_limit
= 2;
282 /* Number of warning messages issued; reset to 0 by cleanups after
283 expression evaluation. */
284 static int warnings_issued
= 0;
286 static const char *known_runtime_file_name_patterns
[] = {
287 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
290 static const char *known_auxiliary_function_name_patterns
[] = {
291 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
294 /* Space for allocating results of ada_lookup_symbol_list. */
295 static struct obstack symbol_list_obstack
;
301 ada_get_gdb_completer_word_break_characters (void)
303 return ada_completer_word_break_characters
;
306 /* Print an array element index using the Ada syntax. */
309 ada_print_array_index (struct value
*index_value
, struct ui_file
*stream
,
310 int format
, enum val_prettyprint pretty
)
312 LA_VALUE_PRINT (index_value
, stream
, format
, pretty
);
313 fprintf_filtered (stream
, " => ");
316 /* Read the string located at ADDR from the inferior and store the
320 extract_string (CORE_ADDR addr
, char *buf
)
324 /* Loop, reading one byte at a time, until we reach the '\000'
325 end-of-string marker. */
328 target_read_memory (addr
+ char_index
* sizeof (char),
329 buf
+ char_index
* sizeof (char), sizeof (char));
332 while (buf
[char_index
- 1] != '\000');
335 /* Assuming VECT points to an array of *SIZE objects of size
336 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
337 updating *SIZE as necessary and returning the (new) array. */
340 grow_vect (void *vect
, size_t *size
, size_t min_size
, int element_size
)
342 if (*size
< min_size
)
345 if (*size
< min_size
)
347 vect
= xrealloc (vect
, *size
* element_size
);
352 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
353 suffix of FIELD_NAME beginning "___". */
356 field_name_match (const char *field_name
, const char *target
)
358 int len
= strlen (target
);
360 (strncmp (field_name
, target
, len
) == 0
361 && (field_name
[len
] == '\0'
362 || (strncmp (field_name
+ len
, "___", 3) == 0
363 && strcmp (field_name
+ strlen (field_name
) - 6,
368 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
369 FIELD_NAME, and return its index. This function also handles fields
370 whose name have ___ suffixes because the compiler sometimes alters
371 their name by adding such a suffix to represent fields with certain
372 constraints. If the field could not be found, return a negative
373 number if MAYBE_MISSING is set. Otherwise raise an error. */
376 ada_get_field_index (const struct type
*type
, const char *field_name
,
380 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
381 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
385 error (_("Unable to find field %s in struct %s. Aborting"),
386 field_name
, TYPE_NAME (type
));
391 /* The length of the prefix of NAME prior to any "___" suffix. */
394 ada_name_prefix_len (const char *name
)
400 const char *p
= strstr (name
, "___");
402 return strlen (name
);
408 /* Return non-zero if SUFFIX is a suffix of STR.
409 Return zero if STR is null. */
412 is_suffix (const char *str
, const char *suffix
)
418 len2
= strlen (suffix
);
419 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
422 /* Create a value of type TYPE whose contents come from VALADDR, if it
423 is non-null, and whose memory address (in the inferior) is
427 value_from_contents_and_address (struct type
*type
,
428 const gdb_byte
*valaddr
,
431 struct value
*v
= allocate_value (type
);
433 set_value_lazy (v
, 1);
435 memcpy (value_contents_raw (v
), valaddr
, TYPE_LENGTH (type
));
436 VALUE_ADDRESS (v
) = address
;
438 VALUE_LVAL (v
) = lval_memory
;
442 /* The contents of value VAL, treated as a value of type TYPE. The
443 result is an lval in memory if VAL is. */
445 static struct value
*
446 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
448 type
= ada_check_typedef (type
);
449 if (value_type (val
) == type
)
453 struct value
*result
;
455 /* Make sure that the object size is not unreasonable before
456 trying to allocate some memory for it. */
459 result
= allocate_value (type
);
460 VALUE_LVAL (result
) = VALUE_LVAL (val
);
461 set_value_bitsize (result
, value_bitsize (val
));
462 set_value_bitpos (result
, value_bitpos (val
));
463 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + value_offset (val
);
465 || TYPE_LENGTH (type
) > TYPE_LENGTH (value_type (val
)))
466 set_value_lazy (result
, 1);
468 memcpy (value_contents_raw (result
), value_contents (val
),
474 static const gdb_byte
*
475 cond_offset_host (const gdb_byte
*valaddr
, long offset
)
480 return valaddr
+ offset
;
484 cond_offset_target (CORE_ADDR address
, long offset
)
489 return address
+ offset
;
492 /* Issue a warning (as for the definition of warning in utils.c, but
493 with exactly one argument rather than ...), unless the limit on the
494 number of warnings has passed during the evaluation of the current
497 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
498 provided by "complaint". */
499 static void lim_warning (const char *format
, ...) ATTR_FORMAT (printf
, 1, 2);
502 lim_warning (const char *format
, ...)
505 va_start (args
, format
);
507 warnings_issued
+= 1;
508 if (warnings_issued
<= warning_limit
)
509 vwarning (format
, args
);
514 /* Issue an error if the size of an object of type T is unreasonable,
515 i.e. if it would be a bad idea to allocate a value of this type in
519 check_size (const struct type
*type
)
521 if (TYPE_LENGTH (type
) > varsize_limit
)
522 error (_("object size is larger than varsize-limit"));
526 /* Note: would have used MAX_OF_TYPE and MIN_OF_TYPE macros from
527 gdbtypes.h, but some of the necessary definitions in that file
528 seem to have gone missing. */
530 /* Maximum value of a SIZE-byte signed integer type. */
532 max_of_size (int size
)
534 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
535 return top_bit
| (top_bit
- 1);
538 /* Minimum value of a SIZE-byte signed integer type. */
540 min_of_size (int size
)
542 return -max_of_size (size
) - 1;
545 /* Maximum value of a SIZE-byte unsigned integer type. */
547 umax_of_size (int size
)
549 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
550 return top_bit
| (top_bit
- 1);
553 /* Maximum value of integral type T, as a signed quantity. */
555 max_of_type (struct type
*t
)
557 if (TYPE_UNSIGNED (t
))
558 return (LONGEST
) umax_of_size (TYPE_LENGTH (t
));
560 return max_of_size (TYPE_LENGTH (t
));
563 /* Minimum value of integral type T, as a signed quantity. */
565 min_of_type (struct type
*t
)
567 if (TYPE_UNSIGNED (t
))
570 return min_of_size (TYPE_LENGTH (t
));
573 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
574 static struct value
*
575 discrete_type_high_bound (struct type
*type
)
577 switch (TYPE_CODE (type
))
579 case TYPE_CODE_RANGE
:
580 return value_from_longest (TYPE_TARGET_TYPE (type
),
581 TYPE_HIGH_BOUND (type
));
584 value_from_longest (type
,
585 TYPE_FIELD_BITPOS (type
,
586 TYPE_NFIELDS (type
) - 1));
588 return value_from_longest (type
, max_of_type (type
));
590 error (_("Unexpected type in discrete_type_high_bound."));
594 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
595 static struct value
*
596 discrete_type_low_bound (struct type
*type
)
598 switch (TYPE_CODE (type
))
600 case TYPE_CODE_RANGE
:
601 return value_from_longest (TYPE_TARGET_TYPE (type
),
602 TYPE_LOW_BOUND (type
));
604 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
606 return value_from_longest (type
, min_of_type (type
));
608 error (_("Unexpected type in discrete_type_low_bound."));
612 /* The identity on non-range types. For range types, the underlying
613 non-range scalar type. */
616 base_type (struct type
*type
)
618 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
620 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
622 type
= TYPE_TARGET_TYPE (type
);
628 /* Language Selection */
630 /* If the main program is in Ada, return language_ada, otherwise return LANG
631 (the main program is in Ada iif the adainit symbol is found).
633 MAIN_PST is not used. */
636 ada_update_initial_language (enum language lang
,
637 struct partial_symtab
*main_pst
)
639 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
640 (struct objfile
*) NULL
) != NULL
)
646 /* If the main procedure is written in Ada, then return its name.
647 The result is good until the next call. Return NULL if the main
648 procedure doesn't appear to be in Ada. */
653 struct minimal_symbol
*msym
;
654 CORE_ADDR main_program_name_addr
;
655 static char main_program_name
[1024];
657 /* For Ada, the name of the main procedure is stored in a specific
658 string constant, generated by the binder. Look for that symbol,
659 extract its address, and then read that string. If we didn't find
660 that string, then most probably the main procedure is not written
662 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
666 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
667 if (main_program_name_addr
== 0)
668 error (_("Invalid address for Ada main program name."));
670 extract_string (main_program_name_addr
, main_program_name
);
671 return main_program_name
;
674 /* The main procedure doesn't seem to be in Ada. */
680 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
683 const struct ada_opname_map ada_opname_table
[] = {
684 {"Oadd", "\"+\"", BINOP_ADD
},
685 {"Osubtract", "\"-\"", BINOP_SUB
},
686 {"Omultiply", "\"*\"", BINOP_MUL
},
687 {"Odivide", "\"/\"", BINOP_DIV
},
688 {"Omod", "\"mod\"", BINOP_MOD
},
689 {"Orem", "\"rem\"", BINOP_REM
},
690 {"Oexpon", "\"**\"", BINOP_EXP
},
691 {"Olt", "\"<\"", BINOP_LESS
},
692 {"Ole", "\"<=\"", BINOP_LEQ
},
693 {"Ogt", "\">\"", BINOP_GTR
},
694 {"Oge", "\">=\"", BINOP_GEQ
},
695 {"Oeq", "\"=\"", BINOP_EQUAL
},
696 {"One", "\"/=\"", BINOP_NOTEQUAL
},
697 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
698 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
699 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
700 {"Oconcat", "\"&\"", BINOP_CONCAT
},
701 {"Oabs", "\"abs\"", UNOP_ABS
},
702 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
703 {"Oadd", "\"+\"", UNOP_PLUS
},
704 {"Osubtract", "\"-\"", UNOP_NEG
},
708 /* Return non-zero if STR should be suppressed in info listings. */
711 is_suppressed_name (const char *str
)
713 if (strncmp (str
, "_ada_", 5) == 0)
715 if (str
[0] == '_' || str
[0] == '\000')
720 const char *suffix
= strstr (str
, "___");
721 if (suffix
!= NULL
&& suffix
[3] != 'X')
724 suffix
= str
+ strlen (str
);
725 for (p
= suffix
- 1; p
!= str
; p
-= 1)
729 if (p
[0] == 'X' && p
[-1] != '_')
733 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
734 if (strncmp (ada_opname_table
[i
].encoded
, p
,
735 strlen (ada_opname_table
[i
].encoded
)) == 0)
744 /* The "encoded" form of DECODED, according to GNAT conventions.
745 The result is valid until the next call to ada_encode. */
748 ada_encode (const char *decoded
)
750 static char *encoding_buffer
= NULL
;
751 static size_t encoding_buffer_size
= 0;
758 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
759 2 * strlen (decoded
) + 10);
762 for (p
= decoded
; *p
!= '\0'; p
+= 1)
764 if (!ADA_RETAIN_DOTS
&& *p
== '.')
766 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
771 const struct ada_opname_map
*mapping
;
773 for (mapping
= ada_opname_table
;
774 mapping
->encoded
!= NULL
775 && strncmp (mapping
->decoded
, p
,
776 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
778 if (mapping
->encoded
== NULL
)
779 error (_("invalid Ada operator name: %s"), p
);
780 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
781 k
+= strlen (mapping
->encoded
);
786 encoding_buffer
[k
] = *p
;
791 encoding_buffer
[k
] = '\0';
792 return encoding_buffer
;
795 /* Return NAME folded to lower case, or, if surrounded by single
796 quotes, unfolded, but with the quotes stripped away. Result good
800 ada_fold_name (const char *name
)
802 static char *fold_buffer
= NULL
;
803 static size_t fold_buffer_size
= 0;
805 int len
= strlen (name
);
806 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
810 strncpy (fold_buffer
, name
+ 1, len
- 2);
811 fold_buffer
[len
- 2] = '\000';
816 for (i
= 0; i
<= len
; i
+= 1)
817 fold_buffer
[i
] = tolower (name
[i
]);
824 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
825 These are suffixes introduced by GNAT5 to nested subprogram
826 names, and do not serve any purpose for the debugger.
827 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
828 2. Convert other instances of embedded "__" to `.'.
829 3. Discard leading _ada_.
830 4. Convert operator names to the appropriate quoted symbols.
831 5. Remove everything after first ___ if it is followed by
833 6. Replace TK__ with __, and a trailing B or TKB with nothing.
834 7. Put symbols that should be suppressed in <...> brackets.
835 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
837 The resulting string is valid until the next call of ada_decode.
838 If the string is unchanged by demangling, the original string pointer
842 ada_decode (const char *encoded
)
849 static char *decoding_buffer
= NULL
;
850 static size_t decoding_buffer_size
= 0;
852 if (strncmp (encoded
, "_ada_", 5) == 0)
855 if (encoded
[0] == '_' || encoded
[0] == '<')
858 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
859 len0
= strlen (encoded
);
860 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
863 while (i
> 0 && isdigit (encoded
[i
]))
865 if (i
>= 0 && encoded
[i
] == '.')
867 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
871 /* Remove the ___X.* suffix if present. Do not forget to verify that
872 the suffix is located before the current "end" of ENCODED. We want
873 to avoid re-matching parts of ENCODED that have previously been
874 marked as discarded (by decrementing LEN0). */
875 p
= strstr (encoded
, "___");
876 if (p
!= NULL
&& p
- encoded
< len0
- 3)
884 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
887 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
890 /* Make decoded big enough for possible expansion by operator name. */
891 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
892 decoded
= decoding_buffer
;
894 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
897 while ((i
>= 0 && isdigit (encoded
[i
]))
898 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
900 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
902 else if (encoded
[i
] == '$')
906 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
907 decoded
[j
] = encoded
[i
];
912 if (at_start_name
&& encoded
[i
] == 'O')
915 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
917 int op_len
= strlen (ada_opname_table
[k
].encoded
);
918 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
920 && !isalnum (encoded
[i
+ op_len
]))
922 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
925 j
+= strlen (ada_opname_table
[k
].decoded
);
929 if (ada_opname_table
[k
].encoded
!= NULL
)
934 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
936 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
940 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
944 else if (!ADA_RETAIN_DOTS
945 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
954 decoded
[j
] = encoded
[i
];
961 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
962 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
965 if (strcmp (decoded
, encoded
) == 0)
971 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
972 decoded
= decoding_buffer
;
973 if (encoded
[0] == '<')
974 strcpy (decoded
, encoded
);
976 sprintf (decoded
, "<%s>", encoded
);
981 /* Table for keeping permanent unique copies of decoded names. Once
982 allocated, names in this table are never released. While this is a
983 storage leak, it should not be significant unless there are massive
984 changes in the set of decoded names in successive versions of a
985 symbol table loaded during a single session. */
986 static struct htab
*decoded_names_store
;
988 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
989 in the language-specific part of GSYMBOL, if it has not been
990 previously computed. Tries to save the decoded name in the same
991 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
992 in any case, the decoded symbol has a lifetime at least that of
994 The GSYMBOL parameter is "mutable" in the C++ sense: logically
995 const, but nevertheless modified to a semantically equivalent form
996 when a decoded name is cached in it.
1000 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1003 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1004 if (*resultp
== NULL
)
1006 const char *decoded
= ada_decode (gsymbol
->name
);
1007 if (gsymbol
->bfd_section
!= NULL
)
1009 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
1012 struct objfile
*objf
;
1015 if (obfd
== objf
->obfd
)
1017 *resultp
= obsavestring (decoded
, strlen (decoded
),
1018 &objf
->objfile_obstack
);
1024 /* Sometimes, we can't find a corresponding objfile, in which
1025 case, we put the result on the heap. Since we only decode
1026 when needed, we hope this usually does not cause a
1027 significant memory leak (FIXME). */
1028 if (*resultp
== NULL
)
1030 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1033 *slot
= xstrdup (decoded
);
1042 ada_la_decode (const char *encoded
, int options
)
1044 return xstrdup (ada_decode (encoded
));
1047 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1048 suffixes that encode debugging information or leading _ada_ on
1049 SYM_NAME (see is_name_suffix commentary for the debugging
1050 information that is ignored). If WILD, then NAME need only match a
1051 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1052 either argument is NULL. */
1055 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1057 if (sym_name
== NULL
|| name
== NULL
)
1060 return wild_match (name
, strlen (name
), sym_name
);
1063 int len_name
= strlen (name
);
1064 return (strncmp (sym_name
, name
, len_name
) == 0
1065 && is_name_suffix (sym_name
+ len_name
))
1066 || (strncmp (sym_name
, "_ada_", 5) == 0
1067 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1068 && is_name_suffix (sym_name
+ len_name
+ 5));
1072 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1073 suppressed in info listings. */
1076 ada_suppress_symbol_printing (struct symbol
*sym
)
1078 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1081 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1087 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1089 static char *bound_name
[] = {
1090 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1091 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1094 /* Maximum number of array dimensions we are prepared to handle. */
1096 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1098 /* Like modify_field, but allows bitpos > wordlength. */
1101 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1103 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1107 /* The desc_* routines return primitive portions of array descriptors
1110 /* The descriptor or array type, if any, indicated by TYPE; removes
1111 level of indirection, if needed. */
1113 static struct type
*
1114 desc_base_type (struct type
*type
)
1118 type
= ada_check_typedef (type
);
1120 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1121 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1122 return ada_check_typedef (TYPE_TARGET_TYPE (type
));
1127 /* True iff TYPE indicates a "thin" array pointer type. */
1130 is_thin_pntr (struct type
*type
)
1133 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1134 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1137 /* The descriptor type for thin pointer type TYPE. */
1139 static struct type
*
1140 thin_descriptor_type (struct type
*type
)
1142 struct type
*base_type
= desc_base_type (type
);
1143 if (base_type
== NULL
)
1145 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1149 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1150 if (alt_type
== NULL
)
1157 /* A pointer to the array data for thin-pointer value VAL. */
1159 static struct value
*
1160 thin_data_pntr (struct value
*val
)
1162 struct type
*type
= value_type (val
);
1163 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1164 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1167 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1168 VALUE_ADDRESS (val
) + value_offset (val
));
1171 /* True iff TYPE indicates a "thick" array pointer type. */
1174 is_thick_pntr (struct type
*type
)
1176 type
= desc_base_type (type
);
1177 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1178 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1181 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1182 pointer to one, the type of its bounds data; otherwise, NULL. */
1184 static struct type
*
1185 desc_bounds_type (struct type
*type
)
1189 type
= desc_base_type (type
);
1193 else if (is_thin_pntr (type
))
1195 type
= thin_descriptor_type (type
);
1198 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1200 return ada_check_typedef (r
);
1202 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1204 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1206 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r
)));
1211 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1212 one, a pointer to its bounds data. Otherwise NULL. */
1214 static struct value
*
1215 desc_bounds (struct value
*arr
)
1217 struct type
*type
= ada_check_typedef (value_type (arr
));
1218 if (is_thin_pntr (type
))
1220 struct type
*bounds_type
=
1221 desc_bounds_type (thin_descriptor_type (type
));
1224 if (desc_bounds_type
== NULL
)
1225 error (_("Bad GNAT array descriptor"));
1227 /* NOTE: The following calculation is not really kosher, but
1228 since desc_type is an XVE-encoded type (and shouldn't be),
1229 the correct calculation is a real pain. FIXME (and fix GCC). */
1230 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1231 addr
= value_as_long (arr
);
1233 addr
= VALUE_ADDRESS (arr
) + value_offset (arr
);
1236 value_from_longest (lookup_pointer_type (bounds_type
),
1237 addr
- TYPE_LENGTH (bounds_type
));
1240 else if (is_thick_pntr (type
))
1241 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1242 _("Bad GNAT array descriptor"));
1247 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1248 position of the field containing the address of the bounds data. */
1251 fat_pntr_bounds_bitpos (struct type
*type
)
1253 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1256 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1257 size of the field containing the address of the bounds data. */
1260 fat_pntr_bounds_bitsize (struct type
*type
)
1262 type
= desc_base_type (type
);
1264 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1265 return TYPE_FIELD_BITSIZE (type
, 1);
1267 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1270 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1271 pointer to one, the type of its array data (a
1272 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1273 ada_type_of_array to get an array type with bounds data. */
1275 static struct type
*
1276 desc_data_type (struct type
*type
)
1278 type
= desc_base_type (type
);
1280 /* NOTE: The following is bogus; see comment in desc_bounds. */
1281 if (is_thin_pntr (type
))
1282 return lookup_pointer_type
1283 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1284 else if (is_thick_pntr (type
))
1285 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1290 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1293 static struct value
*
1294 desc_data (struct value
*arr
)
1296 struct type
*type
= value_type (arr
);
1297 if (is_thin_pntr (type
))
1298 return thin_data_pntr (arr
);
1299 else if (is_thick_pntr (type
))
1300 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1301 _("Bad GNAT array descriptor"));
1307 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1308 position of the field containing the address of the data. */
1311 fat_pntr_data_bitpos (struct type
*type
)
1313 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1316 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1317 size of the field containing the address of the data. */
1320 fat_pntr_data_bitsize (struct type
*type
)
1322 type
= desc_base_type (type
);
1324 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1325 return TYPE_FIELD_BITSIZE (type
, 0);
1327 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1330 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1331 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1332 bound, if WHICH is 1. The first bound is I=1. */
1334 static struct value
*
1335 desc_one_bound (struct value
*bounds
, int i
, int which
)
1337 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1338 _("Bad GNAT array descriptor bounds"));
1341 /* If BOUNDS is an array-bounds structure type, return the bit position
1342 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1343 bound, if WHICH is 1. The first bound is I=1. */
1346 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1348 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1351 /* If BOUNDS is an array-bounds structure type, return the bit field size
1352 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1353 bound, if WHICH is 1. The first bound is I=1. */
1356 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1358 type
= desc_base_type (type
);
1360 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1361 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1363 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1366 /* If TYPE is the type of an array-bounds structure, the type of its
1367 Ith bound (numbering from 1). Otherwise, NULL. */
1369 static struct type
*
1370 desc_index_type (struct type
*type
, int i
)
1372 type
= desc_base_type (type
);
1374 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1375 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1380 /* The number of index positions in the array-bounds type TYPE.
1381 Return 0 if TYPE is NULL. */
1384 desc_arity (struct type
*type
)
1386 type
= desc_base_type (type
);
1389 return TYPE_NFIELDS (type
) / 2;
1393 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1394 an array descriptor type (representing an unconstrained array
1398 ada_is_direct_array_type (struct type
*type
)
1402 type
= ada_check_typedef (type
);
1403 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1404 || ada_is_array_descriptor_type (type
));
1407 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1410 ada_is_simple_array_type (struct type
*type
)
1414 type
= ada_check_typedef (type
);
1415 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1416 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1417 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1420 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1423 ada_is_array_descriptor_type (struct type
*type
)
1425 struct type
*data_type
= desc_data_type (type
);
1429 type
= ada_check_typedef (type
);
1432 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1433 && TYPE_TARGET_TYPE (data_type
) != NULL
1434 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1435 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1436 && desc_arity (desc_bounds_type (type
)) > 0;
1439 /* Non-zero iff type is a partially mal-formed GNAT array
1440 descriptor. FIXME: This is to compensate for some problems with
1441 debugging output from GNAT. Re-examine periodically to see if it
1445 ada_is_bogus_array_descriptor (struct type
*type
)
1449 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1450 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1451 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1452 && !ada_is_array_descriptor_type (type
);
1456 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1457 (fat pointer) returns the type of the array data described---specifically,
1458 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1459 in from the descriptor; otherwise, they are left unspecified. If
1460 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1461 returns NULL. The result is simply the type of ARR if ARR is not
1464 ada_type_of_array (struct value
*arr
, int bounds
)
1466 if (ada_is_packed_array_type (value_type (arr
)))
1467 return decode_packed_array_type (value_type (arr
));
1469 if (!ada_is_array_descriptor_type (value_type (arr
)))
1470 return value_type (arr
);
1474 ada_check_typedef (TYPE_TARGET_TYPE (desc_data_type (value_type (arr
))));
1477 struct type
*elt_type
;
1479 struct value
*descriptor
;
1480 struct objfile
*objf
= TYPE_OBJFILE (value_type (arr
));
1482 elt_type
= ada_array_element_type (value_type (arr
), -1);
1483 arity
= ada_array_arity (value_type (arr
));
1485 if (elt_type
== NULL
|| arity
== 0)
1486 return ada_check_typedef (value_type (arr
));
1488 descriptor
= desc_bounds (arr
);
1489 if (value_as_long (descriptor
) == 0)
1493 struct type
*range_type
= alloc_type (objf
);
1494 struct type
*array_type
= alloc_type (objf
);
1495 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1496 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1499 create_range_type (range_type
, value_type (low
),
1500 (int) value_as_long (low
),
1501 (int) value_as_long (high
));
1502 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1505 return lookup_pointer_type (elt_type
);
1509 /* If ARR does not represent an array, returns ARR unchanged.
1510 Otherwise, returns either a standard GDB array with bounds set
1511 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1512 GDB array. Returns NULL if ARR is a null fat pointer. */
1515 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1517 if (ada_is_array_descriptor_type (value_type (arr
)))
1519 struct type
*arrType
= ada_type_of_array (arr
, 1);
1520 if (arrType
== NULL
)
1522 return value_cast (arrType
, value_copy (desc_data (arr
)));
1524 else if (ada_is_packed_array_type (value_type (arr
)))
1525 return decode_packed_array (arr
);
1530 /* If ARR does not represent an array, returns ARR unchanged.
1531 Otherwise, returns a standard GDB array describing ARR (which may
1532 be ARR itself if it already is in the proper form). */
1534 static struct value
*
1535 ada_coerce_to_simple_array (struct value
*arr
)
1537 if (ada_is_array_descriptor_type (value_type (arr
)))
1539 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1541 error (_("Bounds unavailable for null array pointer."));
1542 return value_ind (arrVal
);
1544 else if (ada_is_packed_array_type (value_type (arr
)))
1545 return decode_packed_array (arr
);
1550 /* If TYPE represents a GNAT array type, return it translated to an
1551 ordinary GDB array type (possibly with BITSIZE fields indicating
1552 packing). For other types, is the identity. */
1555 ada_coerce_to_simple_array_type (struct type
*type
)
1557 struct value
*mark
= value_mark ();
1558 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1559 struct type
*result
;
1560 deprecated_set_value_type (dummy
, type
);
1561 result
= ada_type_of_array (dummy
, 0);
1562 value_free_to_mark (mark
);
1566 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1569 ada_is_packed_array_type (struct type
*type
)
1573 type
= desc_base_type (type
);
1574 type
= ada_check_typedef (type
);
1576 ada_type_name (type
) != NULL
1577 && strstr (ada_type_name (type
), "___XP") != NULL
;
1580 /* Given that TYPE is a standard GDB array type with all bounds filled
1581 in, and that the element size of its ultimate scalar constituents
1582 (that is, either its elements, or, if it is an array of arrays, its
1583 elements' elements, etc.) is *ELT_BITS, return an identical type,
1584 but with the bit sizes of its elements (and those of any
1585 constituent arrays) recorded in the BITSIZE components of its
1586 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1589 static struct type
*
1590 packed_array_type (struct type
*type
, long *elt_bits
)
1592 struct type
*new_elt_type
;
1593 struct type
*new_type
;
1594 LONGEST low_bound
, high_bound
;
1596 type
= ada_check_typedef (type
);
1597 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1600 new_type
= alloc_type (TYPE_OBJFILE (type
));
1601 new_elt_type
= packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type
)),
1603 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1604 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1605 TYPE_NAME (new_type
) = ada_type_name (type
);
1607 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1608 &low_bound
, &high_bound
) < 0)
1609 low_bound
= high_bound
= 0;
1610 if (high_bound
< low_bound
)
1611 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1614 *elt_bits
*= (high_bound
- low_bound
+ 1);
1615 TYPE_LENGTH (new_type
) =
1616 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1619 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1623 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1625 static struct type
*
1626 decode_packed_array_type (struct type
*type
)
1629 struct block
**blocks
;
1630 const char *raw_name
= ada_type_name (ada_check_typedef (type
));
1631 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1632 char *tail
= strstr (raw_name
, "___XP");
1633 struct type
*shadow_type
;
1637 type
= desc_base_type (type
);
1639 memcpy (name
, raw_name
, tail
- raw_name
);
1640 name
[tail
- raw_name
] = '\000';
1642 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1643 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1645 lim_warning (_("could not find bounds information on packed array"));
1648 shadow_type
= SYMBOL_TYPE (sym
);
1650 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1652 lim_warning (_("could not understand bounds information on packed array"));
1656 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1659 (_("could not understand bit size information on packed array"));
1663 return packed_array_type (shadow_type
, &bits
);
1666 /* Given that ARR is a struct value *indicating a GNAT packed array,
1667 returns a simple array that denotes that array. Its type is a
1668 standard GDB array type except that the BITSIZEs of the array
1669 target types are set to the number of bits in each element, and the
1670 type length is set appropriately. */
1672 static struct value
*
1673 decode_packed_array (struct value
*arr
)
1677 arr
= ada_coerce_ref (arr
);
1678 if (TYPE_CODE (value_type (arr
)) == TYPE_CODE_PTR
)
1679 arr
= ada_value_ind (arr
);
1681 type
= decode_packed_array_type (value_type (arr
));
1684 error (_("can't unpack array"));
1688 if (BITS_BIG_ENDIAN
&& ada_is_modular_type (value_type (arr
)))
1690 /* This is a (right-justified) modular type representing a packed
1691 array with no wrapper. In order to interpret the value through
1692 the (left-justified) packed array type we just built, we must
1693 first left-justify it. */
1694 int bit_size
, bit_pos
;
1697 mod
= ada_modulus (value_type (arr
)) - 1;
1704 bit_pos
= HOST_CHAR_BIT
* TYPE_LENGTH (value_type (arr
)) - bit_size
;
1705 arr
= ada_value_primitive_packed_val (arr
, NULL
,
1706 bit_pos
/ HOST_CHAR_BIT
,
1707 bit_pos
% HOST_CHAR_BIT
,
1712 return coerce_unspec_val_to_type (arr
, type
);
1716 /* The value of the element of packed array ARR at the ARITY indices
1717 given in IND. ARR must be a simple array. */
1719 static struct value
*
1720 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1723 int bits
, elt_off
, bit_off
;
1724 long elt_total_bit_offset
;
1725 struct type
*elt_type
;
1729 elt_total_bit_offset
= 0;
1730 elt_type
= ada_check_typedef (value_type (arr
));
1731 for (i
= 0; i
< arity
; i
+= 1)
1733 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1734 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1736 (_("attempt to do packed indexing of something other than a packed array"));
1739 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1740 LONGEST lowerbound
, upperbound
;
1743 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1745 lim_warning (_("don't know bounds of array"));
1746 lowerbound
= upperbound
= 0;
1749 idx
= value_as_long (value_pos_atr (ind
[i
]));
1750 if (idx
< lowerbound
|| idx
> upperbound
)
1751 lim_warning (_("packed array index %ld out of bounds"), (long) idx
);
1752 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1753 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1754 elt_type
= ada_check_typedef (TYPE_TARGET_TYPE (elt_type
));
1757 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1758 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1760 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1762 if (VALUE_LVAL (arr
) == lval_internalvar
)
1763 VALUE_LVAL (v
) = lval_internalvar_component
;
1765 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1769 /* Non-zero iff TYPE includes negative integer values. */
1772 has_negatives (struct type
*type
)
1774 switch (TYPE_CODE (type
))
1779 return !TYPE_UNSIGNED (type
);
1780 case TYPE_CODE_RANGE
:
1781 return TYPE_LOW_BOUND (type
) < 0;
1786 /* Create a new value of type TYPE from the contents of OBJ starting
1787 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1788 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1789 assigning through the result will set the field fetched from.
1790 VALADDR is ignored unless OBJ is NULL, in which case,
1791 VALADDR+OFFSET must address the start of storage containing the
1792 packed value. The value returned in this case is never an lval.
1793 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1796 ada_value_primitive_packed_val (struct value
*obj
, const gdb_byte
*valaddr
,
1797 long offset
, int bit_offset
, int bit_size
,
1801 int src
, /* Index into the source area */
1802 targ
, /* Index into the target area */
1803 srcBitsLeft
, /* Number of source bits left to move */
1804 nsrc
, ntarg
, /* Number of source and target bytes */
1805 unusedLS
, /* Number of bits in next significant
1806 byte of source that are unused */
1807 accumSize
; /* Number of meaningful bits in accum */
1808 unsigned char *bytes
; /* First byte containing data to unpack */
1809 unsigned char *unpacked
;
1810 unsigned long accum
; /* Staging area for bits being transferred */
1812 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1813 /* Transmit bytes from least to most significant; delta is the direction
1814 the indices move. */
1815 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1817 type
= ada_check_typedef (type
);
1821 v
= allocate_value (type
);
1822 bytes
= (unsigned char *) (valaddr
+ offset
);
1824 else if (value_lazy (obj
))
1827 VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
);
1828 bytes
= (unsigned char *) alloca (len
);
1829 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1833 v
= allocate_value (type
);
1834 bytes
= (unsigned char *) value_contents (obj
) + offset
;
1839 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1840 if (VALUE_LVAL (obj
) == lval_internalvar
)
1841 VALUE_LVAL (v
) = lval_internalvar_component
;
1842 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + value_offset (obj
) + offset
;
1843 set_value_bitpos (v
, bit_offset
+ value_bitpos (obj
));
1844 set_value_bitsize (v
, bit_size
);
1845 if (value_bitpos (v
) >= HOST_CHAR_BIT
)
1847 VALUE_ADDRESS (v
) += 1;
1848 set_value_bitpos (v
, value_bitpos (v
) - HOST_CHAR_BIT
);
1852 set_value_bitsize (v
, bit_size
);
1853 unpacked
= (unsigned char *) value_contents (v
);
1855 srcBitsLeft
= bit_size
;
1857 ntarg
= TYPE_LENGTH (type
);
1861 memset (unpacked
, 0, TYPE_LENGTH (type
));
1864 else if (BITS_BIG_ENDIAN
)
1867 if (has_negatives (type
)
1868 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1872 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1875 switch (TYPE_CODE (type
))
1877 case TYPE_CODE_ARRAY
:
1878 case TYPE_CODE_UNION
:
1879 case TYPE_CODE_STRUCT
:
1880 /* Non-scalar values must be aligned at a byte boundary... */
1882 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1883 /* ... And are placed at the beginning (most-significant) bytes
1889 targ
= TYPE_LENGTH (type
) - 1;
1895 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1898 unusedLS
= bit_offset
;
1901 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1908 /* Mask for removing bits of the next source byte that are not
1909 part of the value. */
1910 unsigned int unusedMSMask
=
1911 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1913 /* Sign-extend bits for this byte. */
1914 unsigned int signMask
= sign
& ~unusedMSMask
;
1916 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1917 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1918 if (accumSize
>= HOST_CHAR_BIT
)
1920 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1921 accumSize
-= HOST_CHAR_BIT
;
1922 accum
>>= HOST_CHAR_BIT
;
1926 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1933 accum
|= sign
<< accumSize
;
1934 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1935 accumSize
-= HOST_CHAR_BIT
;
1936 accum
>>= HOST_CHAR_BIT
;
1944 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1945 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1948 move_bits (gdb_byte
*target
, int targ_offset
, const gdb_byte
*source
,
1949 int src_offset
, int n
)
1951 unsigned int accum
, mask
;
1952 int accum_bits
, chunk_size
;
1954 target
+= targ_offset
/ HOST_CHAR_BIT
;
1955 targ_offset
%= HOST_CHAR_BIT
;
1956 source
+= src_offset
/ HOST_CHAR_BIT
;
1957 src_offset
%= HOST_CHAR_BIT
;
1958 if (BITS_BIG_ENDIAN
)
1960 accum
= (unsigned char) *source
;
1962 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1967 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1968 accum_bits
+= HOST_CHAR_BIT
;
1970 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1973 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1974 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1977 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1979 accum_bits
-= chunk_size
;
1986 accum
= (unsigned char) *source
>> src_offset
;
1988 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1992 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1993 accum_bits
+= HOST_CHAR_BIT
;
1995 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1998 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1999 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2001 accum_bits
-= chunk_size
;
2002 accum
>>= chunk_size
;
2010 /* Store the contents of FROMVAL into the location of TOVAL.
2011 Return a new value with the location of TOVAL and contents of
2012 FROMVAL. Handles assignment into packed fields that have
2013 floating-point or non-scalar types. */
2015 static struct value
*
2016 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2018 struct type
*type
= value_type (toval
);
2019 int bits
= value_bitsize (toval
);
2021 if (!deprecated_value_modifiable (toval
))
2022 error (_("Left operand of assignment is not a modifiable lvalue."));
2024 toval
= coerce_ref (toval
);
2026 if (VALUE_LVAL (toval
) == lval_memory
2028 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2029 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2031 int len
= (value_bitpos (toval
)
2032 + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2033 char *buffer
= (char *) alloca (len
);
2036 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2037 fromval
= value_cast (type
, fromval
);
2039 read_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
, len
);
2040 if (BITS_BIG_ENDIAN
)
2041 move_bits (buffer
, value_bitpos (toval
),
2042 value_contents (fromval
),
2043 TYPE_LENGTH (value_type (fromval
)) * TARGET_CHAR_BIT
-
2046 move_bits (buffer
, value_bitpos (toval
), value_contents (fromval
),
2048 write_memory (VALUE_ADDRESS (toval
) + value_offset (toval
), buffer
,
2051 val
= value_copy (toval
);
2052 memcpy (value_contents_raw (val
), value_contents (fromval
),
2053 TYPE_LENGTH (type
));
2054 deprecated_set_value_type (val
, type
);
2059 return value_assign (toval
, fromval
);
2063 /* The value of the element of array ARR at the ARITY indices given in IND.
2064 ARR may be either a simple array, GNAT array descriptor, or pointer
2068 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2072 struct type
*elt_type
;
2074 elt
= ada_coerce_to_simple_array (arr
);
2076 elt_type
= ada_check_typedef (value_type (elt
));
2077 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2078 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2079 return value_subscript_packed (elt
, arity
, ind
);
2081 for (k
= 0; k
< arity
; k
+= 1)
2083 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2084 error (_("too many subscripts (%d expected)"), k
);
2085 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2090 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2091 value of the element of *ARR at the ARITY indices given in
2092 IND. Does not read the entire array into memory. */
2095 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2100 for (k
= 0; k
< arity
; k
+= 1)
2105 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2106 error (_("too many subscripts (%d expected)"), k
);
2107 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2109 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2110 idx
= value_pos_atr (ind
[k
]);
2112 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2113 arr
= value_add (arr
, idx
);
2114 type
= TYPE_TARGET_TYPE (type
);
2117 return value_ind (arr
);
2120 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2121 actual type of ARRAY_PTR is ignored), returns a reference to
2122 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2123 bound of this array is LOW, as per Ada rules. */
2124 static struct value
*
2125 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2128 CORE_ADDR base
= value_as_address (array_ptr
)
2129 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2130 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2131 struct type
*index_type
=
2132 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2134 struct type
*slice_type
=
2135 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2136 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2140 static struct value
*
2141 ada_value_slice (struct value
*array
, int low
, int high
)
2143 struct type
*type
= value_type (array
);
2144 struct type
*index_type
=
2145 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2146 struct type
*slice_type
=
2147 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2148 return value_cast (slice_type
, value_slice (array
, low
, high
- low
+ 1));
2151 /* If type is a record type in the form of a standard GNAT array
2152 descriptor, returns the number of dimensions for type. If arr is a
2153 simple array, returns the number of "array of"s that prefix its
2154 type designation. Otherwise, returns 0. */
2157 ada_array_arity (struct type
*type
)
2164 type
= desc_base_type (type
);
2167 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2168 return desc_arity (desc_bounds_type (type
));
2170 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2173 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
2179 /* If TYPE is a record type in the form of a standard GNAT array
2180 descriptor or a simple array type, returns the element type for
2181 TYPE after indexing by NINDICES indices, or by all indices if
2182 NINDICES is -1. Otherwise, returns NULL. */
2185 ada_array_element_type (struct type
*type
, int nindices
)
2187 type
= desc_base_type (type
);
2189 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2192 struct type
*p_array_type
;
2194 p_array_type
= desc_data_type (type
);
2196 k
= ada_array_arity (type
);
2200 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2201 if (nindices
>= 0 && k
> nindices
)
2203 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2204 while (k
> 0 && p_array_type
!= NULL
)
2206 p_array_type
= ada_check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2209 return p_array_type
;
2211 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2213 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2215 type
= TYPE_TARGET_TYPE (type
);
2224 /* The type of nth index in arrays of given type (n numbering from 1).
2225 Does not examine memory. */
2228 ada_index_type (struct type
*type
, int n
)
2230 struct type
*result_type
;
2232 type
= desc_base_type (type
);
2234 if (n
> ada_array_arity (type
))
2237 if (ada_is_simple_array_type (type
))
2241 for (i
= 1; i
< n
; i
+= 1)
2242 type
= TYPE_TARGET_TYPE (type
);
2243 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2244 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2245 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2246 perhaps stabsread.c would make more sense. */
2247 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2248 result_type
= builtin_type_int
;
2253 return desc_index_type (desc_bounds_type (type
), n
);
2256 /* Given that arr is an array type, returns the lower bound of the
2257 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2258 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2259 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2260 bounds type. It works for other arrays with bounds supplied by
2261 run-time quantities other than discriminants. */
2264 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2265 struct type
** typep
)
2268 struct type
*index_type_desc
;
2270 if (ada_is_packed_array_type (arr_type
))
2271 arr_type
= decode_packed_array_type (arr_type
);
2273 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2276 *typep
= builtin_type_int
;
2277 return (LONGEST
) - which
;
2280 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2281 type
= TYPE_TARGET_TYPE (arr_type
);
2285 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2286 if (index_type_desc
== NULL
)
2288 struct type
*range_type
;
2289 struct type
*index_type
;
2293 type
= TYPE_TARGET_TYPE (type
);
2297 range_type
= TYPE_INDEX_TYPE (type
);
2298 index_type
= TYPE_TARGET_TYPE (range_type
);
2299 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2300 index_type
= builtin_type_long
;
2302 *typep
= index_type
;
2304 (LONGEST
) (which
== 0
2305 ? TYPE_LOW_BOUND (range_type
)
2306 : TYPE_HIGH_BOUND (range_type
));
2310 struct type
*index_type
=
2311 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2312 NULL
, TYPE_OBJFILE (arr_type
));
2314 *typep
= TYPE_TARGET_TYPE (index_type
);
2316 (LONGEST
) (which
== 0
2317 ? TYPE_LOW_BOUND (index_type
)
2318 : TYPE_HIGH_BOUND (index_type
));
2322 /* Given that arr is an array value, returns the lower bound of the
2323 nth index (numbering from 1) if which is 0, and the upper bound if
2324 which is 1. This routine will also work for arrays with bounds
2325 supplied by run-time quantities other than discriminants. */
2328 ada_array_bound (struct value
*arr
, int n
, int which
)
2330 struct type
*arr_type
= value_type (arr
);
2332 if (ada_is_packed_array_type (arr_type
))
2333 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2334 else if (ada_is_simple_array_type (arr_type
))
2337 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2338 return value_from_longest (type
, v
);
2341 return desc_one_bound (desc_bounds (arr
), n
, which
);
2344 /* Given that arr is an array value, returns the length of the
2345 nth index. This routine will also work for arrays with bounds
2346 supplied by run-time quantities other than discriminants.
2347 Does not work for arrays indexed by enumeration types with representation
2348 clauses at the moment. */
2351 ada_array_length (struct value
*arr
, int n
)
2353 struct type
*arr_type
= ada_check_typedef (value_type (arr
));
2355 if (ada_is_packed_array_type (arr_type
))
2356 return ada_array_length (decode_packed_array (arr
), n
);
2358 if (ada_is_simple_array_type (arr_type
))
2362 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2363 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2364 return value_from_longest (type
, v
);
2368 value_from_longest (builtin_type_int
,
2369 value_as_long (desc_one_bound (desc_bounds (arr
),
2371 - value_as_long (desc_one_bound (desc_bounds (arr
),
2375 /* An empty array whose type is that of ARR_TYPE (an array type),
2376 with bounds LOW to LOW-1. */
2378 static struct value
*
2379 empty_array (struct type
*arr_type
, int low
)
2381 struct type
*index_type
=
2382 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2384 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2385 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2389 /* Name resolution */
2391 /* The "decoded" name for the user-definable Ada operator corresponding
2395 ada_decoded_op_name (enum exp_opcode op
)
2399 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2401 if (ada_opname_table
[i
].op
== op
)
2402 return ada_opname_table
[i
].decoded
;
2404 error (_("Could not find operator name for opcode"));
2408 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2409 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2410 undefined namespace) and converts operators that are
2411 user-defined into appropriate function calls. If CONTEXT_TYPE is
2412 non-null, it provides a preferred result type [at the moment, only
2413 type void has any effect---causing procedures to be preferred over
2414 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2415 return type is preferred. May change (expand) *EXP. */
2418 resolve (struct expression
**expp
, int void_context_p
)
2422 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2425 /* Resolve the operator of the subexpression beginning at
2426 position *POS of *EXPP. "Resolving" consists of replacing
2427 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2428 with their resolutions, replacing built-in operators with
2429 function calls to user-defined operators, where appropriate, and,
2430 when DEPROCEDURE_P is non-zero, converting function-valued variables
2431 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2432 are as in ada_resolve, above. */
2434 static struct value
*
2435 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2436 struct type
*context_type
)
2440 struct expression
*exp
; /* Convenience: == *expp. */
2441 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2442 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2443 int nargs
; /* Number of operands. */
2449 /* Pass one: resolve operands, saving their types and updating *pos. */
2453 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2454 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2459 resolve_subexp (expp
, pos
, 0, NULL
);
2461 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2466 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2471 resolve_subexp (expp
, pos
, 0, NULL
);
2474 case OP_ATR_MODULUS
:
2504 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2506 resolve_subexp (expp
, pos
, 1, NULL
);
2508 resolve_subexp (expp
, pos
, 1, value_type (arg1
));
2526 case BINOP_LOGICAL_AND
:
2527 case BINOP_LOGICAL_OR
:
2528 case BINOP_BITWISE_AND
:
2529 case BINOP_BITWISE_IOR
:
2530 case BINOP_BITWISE_XOR
:
2533 case BINOP_NOTEQUAL
:
2540 case BINOP_SUBSCRIPT
:
2548 case UNOP_LOGICAL_NOT
:
2565 case OP_INTERNALVAR
:
2574 case STRUCTOP_STRUCT
:
2575 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2581 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2586 case TERNOP_IN_RANGE
:
2591 case BINOP_IN_BOUNDS
:
2597 error (_("Unexpected operator during name resolution"));
2600 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2601 for (i
= 0; i
< nargs
; i
+= 1)
2602 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2606 /* Pass two: perform any resolution on principal operator. */
2613 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2615 struct ada_symbol_info
*candidates
;
2619 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2620 (exp
->elts
[pc
+ 2].symbol
),
2621 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2624 if (n_candidates
> 1)
2626 /* Types tend to get re-introduced locally, so if there
2627 are any local symbols that are not types, first filter
2630 for (j
= 0; j
< n_candidates
; j
+= 1)
2631 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2637 case LOC_REGPARM_ADDR
:
2641 case LOC_BASEREG_ARG
:
2643 case LOC_COMPUTED_ARG
:
2649 if (j
< n_candidates
)
2652 while (j
< n_candidates
)
2654 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2656 candidates
[j
] = candidates
[n_candidates
- 1];
2665 if (n_candidates
== 0)
2666 error (_("No definition found for %s"),
2667 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2668 else if (n_candidates
== 1)
2670 else if (deprocedure_p
2671 && !is_nonfunction (candidates
, n_candidates
))
2673 i
= ada_resolve_function
2674 (candidates
, n_candidates
, NULL
, 0,
2675 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2678 error (_("Could not find a match for %s"),
2679 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2683 printf_filtered (_("Multiple matches for %s\n"),
2684 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2685 user_select_syms (candidates
, n_candidates
, 1);
2689 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2690 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2691 if (innermost_block
== NULL
2692 || contained_in (candidates
[i
].block
, innermost_block
))
2693 innermost_block
= candidates
[i
].block
;
2697 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2700 replace_operator_with_call (expp
, pc
, 0, 0,
2701 exp
->elts
[pc
+ 2].symbol
,
2702 exp
->elts
[pc
+ 1].block
);
2709 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2710 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2712 struct ada_symbol_info
*candidates
;
2716 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2717 (exp
->elts
[pc
+ 5].symbol
),
2718 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2720 if (n_candidates
== 1)
2724 i
= ada_resolve_function
2725 (candidates
, n_candidates
,
2727 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2730 error (_("Could not find a match for %s"),
2731 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2734 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2735 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2736 if (innermost_block
== NULL
2737 || contained_in (candidates
[i
].block
, innermost_block
))
2738 innermost_block
= candidates
[i
].block
;
2749 case BINOP_BITWISE_AND
:
2750 case BINOP_BITWISE_IOR
:
2751 case BINOP_BITWISE_XOR
:
2753 case BINOP_NOTEQUAL
:
2761 case UNOP_LOGICAL_NOT
:
2763 if (possible_user_operator_p (op
, argvec
))
2765 struct ada_symbol_info
*candidates
;
2769 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2770 (struct block
*) NULL
, VAR_DOMAIN
,
2772 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2773 ada_decoded_op_name (op
), NULL
);
2777 replace_operator_with_call (expp
, pc
, nargs
, 1,
2778 candidates
[i
].sym
, candidates
[i
].block
);
2788 return evaluate_subexp_type (exp
, pos
);
2791 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2792 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2793 a non-pointer. A type of 'void' (which is never a valid expression type)
2794 by convention matches anything. */
2795 /* The term "match" here is rather loose. The match is heuristic and
2796 liberal. FIXME: TOO liberal, in fact. */
2799 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2801 ftype
= ada_check_typedef (ftype
);
2802 atype
= ada_check_typedef (atype
);
2804 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2805 ftype
= TYPE_TARGET_TYPE (ftype
);
2806 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2807 atype
= TYPE_TARGET_TYPE (atype
);
2809 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2810 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2813 switch (TYPE_CODE (ftype
))
2818 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2819 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2820 TYPE_TARGET_TYPE (atype
), 0);
2823 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2825 case TYPE_CODE_ENUM
:
2826 case TYPE_CODE_RANGE
:
2827 switch (TYPE_CODE (atype
))
2830 case TYPE_CODE_ENUM
:
2831 case TYPE_CODE_RANGE
:
2837 case TYPE_CODE_ARRAY
:
2838 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2839 || ada_is_array_descriptor_type (atype
));
2841 case TYPE_CODE_STRUCT
:
2842 if (ada_is_array_descriptor_type (ftype
))
2843 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2844 || ada_is_array_descriptor_type (atype
));
2846 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2847 && !ada_is_array_descriptor_type (atype
));
2849 case TYPE_CODE_UNION
:
2851 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2855 /* Return non-zero if the formals of FUNC "sufficiently match" the
2856 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2857 may also be an enumeral, in which case it is treated as a 0-
2858 argument function. */
2861 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2864 struct type
*func_type
= SYMBOL_TYPE (func
);
2866 if (SYMBOL_CLASS (func
) == LOC_CONST
2867 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2868 return (n_actuals
== 0);
2869 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2872 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2875 for (i
= 0; i
< n_actuals
; i
+= 1)
2877 if (actuals
[i
] == NULL
)
2881 struct type
*ftype
= ada_check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2882 struct type
*atype
= ada_check_typedef (value_type (actuals
[i
]));
2884 if (!ada_type_match (ftype
, atype
, 1))
2891 /* False iff function type FUNC_TYPE definitely does not produce a value
2892 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2893 FUNC_TYPE is not a valid function type with a non-null return type
2894 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2897 return_match (struct type
*func_type
, struct type
*context_type
)
2899 struct type
*return_type
;
2901 if (func_type
== NULL
)
2904 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2905 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2907 return_type
= base_type (func_type
);
2908 if (return_type
== NULL
)
2911 context_type
= base_type (context_type
);
2913 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2914 return context_type
== NULL
|| return_type
== context_type
;
2915 else if (context_type
== NULL
)
2916 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2918 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2922 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
2923 function (if any) that matches the types of the NARGS arguments in
2924 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2925 that returns that type, then eliminate matches that don't. If
2926 CONTEXT_TYPE is void and there is at least one match that does not
2927 return void, eliminate all matches that do.
2929 Asks the user if there is more than one match remaining. Returns -1
2930 if there is no such symbol or none is selected. NAME is used
2931 solely for messages. May re-arrange and modify SYMS in
2932 the process; the index returned is for the modified vector. */
2935 ada_resolve_function (struct ada_symbol_info syms
[],
2936 int nsyms
, struct value
**args
, int nargs
,
2937 const char *name
, struct type
*context_type
)
2940 int m
; /* Number of hits */
2941 struct type
*fallback
;
2942 struct type
*return_type
;
2944 return_type
= context_type
;
2945 if (context_type
== NULL
)
2946 fallback
= builtin_type_void
;
2953 for (k
= 0; k
< nsyms
; k
+= 1)
2955 struct type
*type
= ada_check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
2957 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
2958 && return_match (type
, return_type
))
2964 if (m
> 0 || return_type
== fallback
)
2967 return_type
= fallback
;
2974 printf_filtered (_("Multiple matches for %s\n"), name
);
2975 user_select_syms (syms
, m
, 1);
2981 /* Returns true (non-zero) iff decoded name N0 should appear before N1
2982 in a listing of choices during disambiguation (see sort_choices, below).
2983 The idea is that overloadings of a subprogram name from the
2984 same package should sort in their source order. We settle for ordering
2985 such symbols by their trailing number (__N or $N). */
2988 encoded_ordered_before (char *N0
, char *N1
)
2992 else if (N0
== NULL
)
2997 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2999 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3001 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3002 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3006 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3009 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3011 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3012 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3014 return (strcmp (N0
, N1
) < 0);
3018 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3022 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3025 for (i
= 1; i
< nsyms
; i
+= 1)
3027 struct ada_symbol_info sym
= syms
[i
];
3030 for (j
= i
- 1; j
>= 0; j
-= 1)
3032 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3033 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3035 syms
[j
+ 1] = syms
[j
];
3041 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3042 by asking the user (if necessary), returning the number selected,
3043 and setting the first elements of SYMS items. Error if no symbols
3046 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3047 to be re-integrated one of these days. */
3050 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3053 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3055 int first_choice
= (max_results
== 1) ? 1 : 2;
3057 if (max_results
< 1)
3058 error (_("Request to select 0 symbols!"));
3062 printf_unfiltered (_("[0] cancel\n"));
3063 if (max_results
> 1)
3064 printf_unfiltered (_("[1] all\n"));
3066 sort_choices (syms
, nsyms
);
3068 for (i
= 0; i
< nsyms
; i
+= 1)
3070 if (syms
[i
].sym
== NULL
)
3073 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3075 struct symtab_and_line sal
=
3076 find_function_start_sal (syms
[i
].sym
, 1);
3077 if (sal
.symtab
== NULL
)
3078 printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3080 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3083 printf_unfiltered (_("[%d] %s at %s:%d\n"), i
+ first_choice
,
3084 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3085 sal
.symtab
->filename
, sal
.line
);
3091 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3092 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3093 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3094 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3096 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3097 printf_unfiltered (_("[%d] %s at %s:%d\n"),
3099 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3100 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3101 else if (is_enumeral
3102 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3104 printf_unfiltered (("[%d] "), i
+ first_choice
);
3105 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3107 printf_unfiltered (_("'(%s) (enumeral)\n"),
3108 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3110 else if (symtab
!= NULL
)
3111 printf_unfiltered (is_enumeral
3112 ? _("[%d] %s in %s (enumeral)\n")
3113 : _("[%d] %s at %s:?\n"),
3115 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3118 printf_unfiltered (is_enumeral
3119 ? _("[%d] %s (enumeral)\n")
3120 : _("[%d] %s at ?\n"),
3122 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3126 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3129 for (i
= 0; i
< n_chosen
; i
+= 1)
3130 syms
[i
] = syms
[chosen
[i
]];
3135 /* Read and validate a set of numeric choices from the user in the
3136 range 0 .. N_CHOICES-1. Place the results in increasing
3137 order in CHOICES[0 .. N-1], and return N.
3139 The user types choices as a sequence of numbers on one line
3140 separated by blanks, encoding them as follows:
3142 + A choice of 0 means to cancel the selection, throwing an error.
3143 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3144 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3146 The user is not allowed to choose more than MAX_RESULTS values.
3148 ANNOTATION_SUFFIX, if present, is used to annotate the input
3149 prompts (for use with the -f switch). */
3152 get_selections (int *choices
, int n_choices
, int max_results
,
3153 int is_all_choice
, char *annotation_suffix
)
3158 int first_choice
= is_all_choice
? 2 : 1;
3160 prompt
= getenv ("PS2");
3164 printf_unfiltered (("%s "), prompt
);
3165 gdb_flush (gdb_stdout
);
3167 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3170 error_no_arg (_("one or more choice numbers"));
3174 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3175 order, as given in args. Choices are validated. */
3181 while (isspace (*args
))
3183 if (*args
== '\0' && n_chosen
== 0)
3184 error_no_arg (_("one or more choice numbers"));
3185 else if (*args
== '\0')
3188 choice
= strtol (args
, &args2
, 10);
3189 if (args
== args2
|| choice
< 0
3190 || choice
> n_choices
+ first_choice
- 1)
3191 error (_("Argument must be choice number"));
3195 error (_("cancelled"));
3197 if (choice
< first_choice
)
3199 n_chosen
= n_choices
;
3200 for (j
= 0; j
< n_choices
; j
+= 1)
3204 choice
-= first_choice
;
3206 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3210 if (j
< 0 || choice
!= choices
[j
])
3213 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3214 choices
[k
+ 1] = choices
[k
];
3215 choices
[j
+ 1] = choice
;
3220 if (n_chosen
> max_results
)
3221 error (_("Select no more than %d of the above"), max_results
);
3226 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3227 on the function identified by SYM and BLOCK, and taking NARGS
3228 arguments. Update *EXPP as needed to hold more space. */
3231 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3232 int oplen
, struct symbol
*sym
,
3233 struct block
*block
)
3235 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3236 symbol, -oplen for operator being replaced). */
3237 struct expression
*newexp
= (struct expression
*)
3238 xmalloc (sizeof (struct expression
)
3239 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3240 struct expression
*exp
= *expp
;
3242 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3243 newexp
->language_defn
= exp
->language_defn
;
3244 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3245 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3246 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3248 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3249 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3251 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3252 newexp
->elts
[pc
+ 4].block
= block
;
3253 newexp
->elts
[pc
+ 5].symbol
= sym
;
3259 /* Type-class predicates */
3261 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3265 numeric_type_p (struct type
*type
)
3271 switch (TYPE_CODE (type
))
3276 case TYPE_CODE_RANGE
:
3277 return (type
== TYPE_TARGET_TYPE (type
)
3278 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3285 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3288 integer_type_p (struct type
*type
)
3294 switch (TYPE_CODE (type
))
3298 case TYPE_CODE_RANGE
:
3299 return (type
== TYPE_TARGET_TYPE (type
)
3300 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3307 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3310 scalar_type_p (struct type
*type
)
3316 switch (TYPE_CODE (type
))
3319 case TYPE_CODE_RANGE
:
3320 case TYPE_CODE_ENUM
:
3329 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3332 discrete_type_p (struct type
*type
)
3338 switch (TYPE_CODE (type
))
3341 case TYPE_CODE_RANGE
:
3342 case TYPE_CODE_ENUM
:
3350 /* Returns non-zero if OP with operands in the vector ARGS could be
3351 a user-defined function. Errs on the side of pre-defined operators
3352 (i.e., result 0). */
3355 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3357 struct type
*type0
=
3358 (args
[0] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[0]));
3359 struct type
*type1
=
3360 (args
[1] == NULL
) ? NULL
: ada_check_typedef (value_type (args
[1]));
3374 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3378 case BINOP_BITWISE_AND
:
3379 case BINOP_BITWISE_IOR
:
3380 case BINOP_BITWISE_XOR
:
3381 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3384 case BINOP_NOTEQUAL
:
3389 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3393 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3394 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3395 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3396 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3397 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3398 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
))
3399 != TYPE_CODE_ARRAY
))));
3402 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3406 case UNOP_LOGICAL_NOT
:
3408 return (!numeric_type_p (type0
));
3415 /* NOTE: In the following, we assume that a renaming type's name may
3416 have an ___XD suffix. It would be nice if this went away at some
3419 /* If TYPE encodes a renaming, returns the renaming suffix, which
3420 is XR for an object renaming, XRP for a procedure renaming, XRE for
3421 an exception renaming, and XRS for a subprogram renaming. Returns
3422 NULL if NAME encodes none of these. */
3425 ada_renaming_type (struct type
*type
)
3427 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3429 const char *name
= type_name_no_tag (type
);
3430 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3432 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3441 /* Return non-zero iff SYM encodes an object renaming. */
3444 ada_is_object_renaming (struct symbol
*sym
)
3446 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3447 return renaming_type
!= NULL
3448 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3451 /* Assuming that SYM encodes a non-object renaming, returns the original
3452 name of the renamed entity. The name is good until the end of
3456 ada_simple_renamed_entity (struct symbol
*sym
)
3459 const char *raw_name
;
3463 type
= SYMBOL_TYPE (sym
);
3464 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3465 error (_("Improperly encoded renaming."));
3467 raw_name
= TYPE_FIELD_NAME (type
, 0);
3468 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3470 error (_("Improperly encoded renaming."));
3472 result
= xmalloc (len
+ 1);
3473 strncpy (result
, raw_name
, len
);
3474 result
[len
] = '\000';
3479 /* Evaluation: Function Calls */
3481 /* Return an lvalue containing the value VAL. This is the identity on
3482 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3483 on the stack, using and updating *SP as the stack pointer, and
3484 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3486 static struct value
*
3487 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3489 if (! VALUE_LVAL (val
))
3491 int len
= TYPE_LENGTH (ada_check_typedef (value_type (val
)));
3493 /* The following is taken from the structure-return code in
3494 call_function_by_hand. FIXME: Therefore, some refactoring seems
3496 if (INNER_THAN (1, 2))
3498 /* Stack grows downward. Align SP and VALUE_ADDRESS (val) after
3499 reserving sufficient space. */
3501 if (gdbarch_frame_align_p (current_gdbarch
))
3502 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3503 VALUE_ADDRESS (val
) = *sp
;
3507 /* Stack grows upward. Align the frame, allocate space, and
3508 then again, re-align the frame. */
3509 if (gdbarch_frame_align_p (current_gdbarch
))
3510 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3511 VALUE_ADDRESS (val
) = *sp
;
3513 if (gdbarch_frame_align_p (current_gdbarch
))
3514 *sp
= gdbarch_frame_align (current_gdbarch
, *sp
);
3517 write_memory (VALUE_ADDRESS (val
), value_contents_raw (val
), len
);
3523 /* Return the value ACTUAL, converted to be an appropriate value for a
3524 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3525 allocating any necessary descriptors (fat pointers), or copies of
3526 values not residing in memory, updating it as needed. */
3528 static struct value
*
3529 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3532 struct type
*actual_type
= ada_check_typedef (value_type (actual
));
3533 struct type
*formal_type
= ada_check_typedef (formal_type0
);
3534 struct type
*formal_target
=
3535 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3536 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3537 struct type
*actual_target
=
3538 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3539 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3541 if (ada_is_array_descriptor_type (formal_target
)
3542 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3543 return make_array_descriptor (formal_type
, actual
, sp
);
3544 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3546 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3547 && ada_is_array_descriptor_type (actual_target
))
3548 return desc_data (actual
);
3549 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3551 if (VALUE_LVAL (actual
) != lval_memory
)
3554 actual_type
= ada_check_typedef (value_type (actual
));
3555 val
= allocate_value (actual_type
);
3556 memcpy ((char *) value_contents_raw (val
),
3557 (char *) value_contents (actual
),
3558 TYPE_LENGTH (actual_type
));
3559 actual
= ensure_lval (val
, sp
);
3561 return value_addr (actual
);
3564 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3565 return ada_value_ind (actual
);
3571 /* Push a descriptor of type TYPE for array value ARR on the stack at
3572 *SP, updating *SP to reflect the new descriptor. Return either
3573 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3574 to-descriptor type rather than a descriptor type), a struct value *
3575 representing a pointer to this descriptor. */
3577 static struct value
*
3578 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3580 struct type
*bounds_type
= desc_bounds_type (type
);
3581 struct type
*desc_type
= desc_base_type (type
);
3582 struct value
*descriptor
= allocate_value (desc_type
);
3583 struct value
*bounds
= allocate_value (bounds_type
);
3586 for (i
= ada_array_arity (ada_check_typedef (value_type (arr
))); i
> 0; i
-= 1)
3588 modify_general_field (value_contents_writeable (bounds
),
3589 value_as_long (ada_array_bound (arr
, i
, 0)),
3590 desc_bound_bitpos (bounds_type
, i
, 0),
3591 desc_bound_bitsize (bounds_type
, i
, 0));
3592 modify_general_field (value_contents_writeable (bounds
),
3593 value_as_long (ada_array_bound (arr
, i
, 1)),
3594 desc_bound_bitpos (bounds_type
, i
, 1),
3595 desc_bound_bitsize (bounds_type
, i
, 1));
3598 bounds
= ensure_lval (bounds
, sp
);
3600 modify_general_field (value_contents_writeable (descriptor
),
3601 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3602 fat_pntr_data_bitpos (desc_type
),
3603 fat_pntr_data_bitsize (desc_type
));
3605 modify_general_field (value_contents_writeable (descriptor
),
3606 VALUE_ADDRESS (bounds
),
3607 fat_pntr_bounds_bitpos (desc_type
),
3608 fat_pntr_bounds_bitsize (desc_type
));
3610 descriptor
= ensure_lval (descriptor
, sp
);
3612 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3613 return value_addr (descriptor
);
3619 /* Assuming a dummy frame has been established on the target, perform any
3620 conversions needed for calling function FUNC on the NARGS actual
3621 parameters in ARGS, other than standard C conversions. Does
3622 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3623 does not match the number of arguments expected. Use *SP as a
3624 stack pointer for additional data that must be pushed, updating its
3628 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3633 if (TYPE_NFIELDS (value_type (func
)) == 0
3634 || nargs
!= TYPE_NFIELDS (value_type (func
)))
3637 for (i
= 0; i
< nargs
; i
+= 1)
3639 convert_actual (args
[i
], TYPE_FIELD_TYPE (value_type (func
), i
), sp
);
3642 /* Dummy definitions for an experimental caching module that is not
3643 * used in the public sources. */
3646 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3647 struct symbol
**sym
, struct block
**block
,
3648 struct symtab
**symtab
)
3654 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3655 struct block
*block
, struct symtab
*symtab
)
3661 /* Return the result of a standard (literal, C-like) lookup of NAME in
3662 given DOMAIN, visible from lexical block BLOCK. */
3664 static struct symbol
*
3665 standard_lookup (const char *name
, const struct block
*block
,
3669 struct symtab
*symtab
;
3671 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3674 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3675 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3680 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3681 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3682 since they contend in overloading in the same way. */
3684 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3688 for (i
= 0; i
< n
; i
+= 1)
3689 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3690 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3691 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3697 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3698 struct types. Otherwise, they may not. */
3701 equiv_types (struct type
*type0
, struct type
*type1
)
3705 if (type0
== NULL
|| type1
== NULL
3706 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3708 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3709 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3710 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3711 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3717 /* True iff SYM0 represents the same entity as SYM1, or one that is
3718 no more defined than that of SYM1. */
3721 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3725 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3726 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3729 switch (SYMBOL_CLASS (sym0
))
3735 struct type
*type0
= SYMBOL_TYPE (sym0
);
3736 struct type
*type1
= SYMBOL_TYPE (sym1
);
3737 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3738 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3739 int len0
= strlen (name0
);
3741 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3742 && (equiv_types (type0
, type1
)
3743 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3744 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3747 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3748 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3754 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3755 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3758 add_defn_to_vec (struct obstack
*obstackp
,
3760 struct block
*block
, struct symtab
*symtab
)
3764 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3766 if (SYMBOL_TYPE (sym
) != NULL
)
3767 SYMBOL_TYPE (sym
) = ada_check_typedef (SYMBOL_TYPE (sym
));
3768 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3770 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3772 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3774 prevDefns
[i
].sym
= sym
;
3775 prevDefns
[i
].block
= block
;
3776 prevDefns
[i
].symtab
= symtab
;
3782 struct ada_symbol_info info
;
3786 info
.symtab
= symtab
;
3787 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3791 /* Number of ada_symbol_info structures currently collected in
3792 current vector in *OBSTACKP. */
3795 num_defns_collected (struct obstack
*obstackp
)
3797 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3800 /* Vector of ada_symbol_info structures currently collected in current
3801 vector in *OBSTACKP. If FINISH, close off the vector and return
3802 its final address. */
3804 static struct ada_symbol_info
*
3805 defns_collected (struct obstack
*obstackp
, int finish
)
3808 return obstack_finish (obstackp
);
3810 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3813 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3814 Check the global symbols if GLOBAL, the static symbols if not.
3815 Do wild-card match if WILD. */
3817 static struct partial_symbol
*
3818 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3819 int global
, domain_enum
namespace, int wild
)
3821 struct partial_symbol
**start
;
3822 int name_len
= strlen (name
);
3823 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3832 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3833 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3837 for (i
= 0; i
< length
; i
+= 1)
3839 struct partial_symbol
*psym
= start
[i
];
3841 if (SYMBOL_DOMAIN (psym
) == namespace
3842 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3856 int M
= (U
+ i
) >> 1;
3857 struct partial_symbol
*psym
= start
[M
];
3858 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3860 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3862 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
3873 struct partial_symbol
*psym
= start
[i
];
3875 if (SYMBOL_DOMAIN (psym
) == namespace)
3877 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
3885 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3899 int M
= (U
+ i
) >> 1;
3900 struct partial_symbol
*psym
= start
[M
];
3901 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
3903 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
3905 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
3916 struct partial_symbol
*psym
= start
[i
];
3918 if (SYMBOL_DOMAIN (psym
) == namespace)
3922 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
3925 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
3927 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
3937 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
3947 /* Find a symbol table containing symbol SYM or NULL if none. */
3949 static struct symtab
*
3950 symtab_for_sym (struct symbol
*sym
)
3953 struct objfile
*objfile
;
3955 struct symbol
*tmp_sym
;
3956 struct dict_iterator iter
;
3959 ALL_SYMTABS (objfile
, s
)
3961 switch (SYMBOL_CLASS (sym
))
3969 case LOC_CONST_BYTES
:
3970 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3971 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3973 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3974 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
3980 switch (SYMBOL_CLASS (sym
))
3986 case LOC_REGPARM_ADDR
:
3991 case LOC_BASEREG_ARG
:
3993 case LOC_COMPUTED_ARG
:
3994 for (j
= FIRST_LOCAL_BLOCK
;
3995 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3997 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3998 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4009 /* Return a minimal symbol matching NAME according to Ada decoding
4010 rules. Returns NULL if there is no such minimal symbol. Names
4011 prefixed with "standard__" are handled specially: "standard__" is
4012 first stripped off, and only static and global symbols are searched. */
4014 struct minimal_symbol
*
4015 ada_lookup_simple_minsym (const char *name
)
4017 struct objfile
*objfile
;
4018 struct minimal_symbol
*msymbol
;
4021 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4023 name
+= sizeof ("standard__") - 1;
4027 wild_match
= (strstr (name
, "__") == NULL
);
4029 ALL_MSYMBOLS (objfile
, msymbol
)
4031 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4032 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4039 /* For all subprograms that statically enclose the subprogram of the
4040 selected frame, add symbols matching identifier NAME in DOMAIN
4041 and their blocks to the list of data in OBSTACKP, as for
4042 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4046 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4047 const char *name
, domain_enum
namespace,
4052 /* FIXME: The next two routines belong in symtab.c */
4055 restore_language (void *lang
)
4057 set_language ((enum language
) lang
);
4060 /* As for lookup_symbol, but performed as if the current language
4064 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4065 domain_enum domain
, enum language lang
,
4066 int *is_a_field_of_this
, struct symtab
**symtab
)
4068 struct cleanup
*old_chain
4069 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4070 struct symbol
*result
;
4071 set_language (lang
);
4072 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4073 do_cleanups (old_chain
);
4077 /* True if TYPE is definitely an artificial type supplied to a symbol
4078 for which no debugging information was given in the symbol file. */
4081 is_nondebugging_type (struct type
*type
)
4083 char *name
= ada_type_name (type
);
4084 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4087 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4088 duplicate other symbols in the list (The only case I know of where
4089 this happens is when object files containing stabs-in-ecoff are
4090 linked with files containing ordinary ecoff debugging symbols (or no
4091 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4092 Returns the number of items in the modified list. */
4095 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4102 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4103 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4104 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4106 for (j
= 0; j
< nsyms
; j
+= 1)
4109 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4110 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4111 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4112 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4113 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4114 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4117 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4118 syms
[k
- 1] = syms
[k
];
4131 /* Given a type that corresponds to a renaming entity, use the type name
4132 to extract the scope (package name or function name, fully qualified,
4133 and following the GNAT encoding convention) where this renaming has been
4134 defined. The string returned needs to be deallocated after use. */
4137 xget_renaming_scope (struct type
*renaming_type
)
4139 /* The renaming types adhere to the following convention:
4140 <scope>__<rename>___<XR extension>.
4141 So, to extract the scope, we search for the "___XR" extension,
4142 and then backtrack until we find the first "__". */
4144 const char *name
= type_name_no_tag (renaming_type
);
4145 char *suffix
= strstr (name
, "___XR");
4150 /* Now, backtrack a bit until we find the first "__". Start looking
4151 at suffix - 3, as the <rename> part is at least one character long. */
4153 for (last
= suffix
- 3; last
> name
; last
--)
4154 if (last
[0] == '_' && last
[1] == '_')
4157 /* Make a copy of scope and return it. */
4159 scope_len
= last
- name
;
4160 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4162 strncpy (scope
, name
, scope_len
);
4163 scope
[scope_len
] = '\0';
4168 /* Return nonzero if NAME corresponds to a package name. */
4171 is_package_name (const char *name
)
4173 /* Here, We take advantage of the fact that no symbols are generated
4174 for packages, while symbols are generated for each function.
4175 So the condition for NAME represent a package becomes equivalent
4176 to NAME not existing in our list of symbols. There is only one
4177 small complication with library-level functions (see below). */
4181 /* If it is a function that has not been defined at library level,
4182 then we should be able to look it up in the symbols. */
4183 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4186 /* Library-level function names start with "_ada_". See if function
4187 "_ada_" followed by NAME can be found. */
4189 /* Do a quick check that NAME does not contain "__", since library-level
4190 functions names can not contain "__" in them. */
4191 if (strstr (name
, "__") != NULL
)
4194 fun_name
= xstrprintf ("_ada_%s", name
);
4196 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4199 /* Return nonzero if SYM corresponds to a renaming entity that is
4200 visible from FUNCTION_NAME. */
4203 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4205 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4207 make_cleanup (xfree
, scope
);
4209 /* If the rename has been defined in a package, then it is visible. */
4210 if (is_package_name (scope
))
4213 /* Check that the rename is in the current function scope by checking
4214 that its name starts with SCOPE. */
4216 /* If the function name starts with "_ada_", it means that it is
4217 a library-level function. Strip this prefix before doing the
4218 comparison, as the encoding for the renaming does not contain
4220 if (strncmp (function_name
, "_ada_", 5) == 0)
4223 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4226 /* Iterates over the SYMS list and remove any entry that corresponds to
4227 a renaming entity that is not visible from the function associated
4231 GNAT emits a type following a specified encoding for each renaming
4232 entity. Unfortunately, STABS currently does not support the definition
4233 of types that are local to a given lexical block, so all renamings types
4234 are emitted at library level. As a consequence, if an application
4235 contains two renaming entities using the same name, and a user tries to
4236 print the value of one of these entities, the result of the ada symbol
4237 lookup will also contain the wrong renaming type.
4239 This function partially covers for this limitation by attempting to
4240 remove from the SYMS list renaming symbols that should be visible
4241 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4242 method with the current information available. The implementation
4243 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4245 - When the user tries to print a rename in a function while there
4246 is another rename entity defined in a package: Normally, the
4247 rename in the function has precedence over the rename in the
4248 package, so the latter should be removed from the list. This is
4249 currently not the case.
4251 - This function will incorrectly remove valid renames if
4252 the CURRENT_BLOCK corresponds to a function which symbol name
4253 has been changed by an "Export" pragma. As a consequence,
4254 the user will be unable to print such rename entities. */
4257 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4258 int nsyms
, struct block
*current_block
)
4260 struct symbol
*current_function
;
4261 char *current_function_name
;
4264 /* Extract the function name associated to CURRENT_BLOCK.
4265 Abort if unable to do so. */
4267 if (current_block
== NULL
)
4270 current_function
= block_function (current_block
);
4271 if (current_function
== NULL
)
4274 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4275 if (current_function_name
== NULL
)
4278 /* Check each of the symbols, and remove it from the list if it is
4279 a type corresponding to a renaming that is out of the scope of
4280 the current block. */
4285 if (ada_is_object_renaming (syms
[i
].sym
)
4286 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4289 for (j
= i
+ 1; j
< nsyms
; j
++)
4290 syms
[j
- 1] = syms
[j
];
4300 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4301 scope and in global scopes, returning the number of matches. Sets
4302 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4303 indicating the symbols found and the blocks and symbol tables (if
4304 any) in which they were found. This vector are transient---good only to
4305 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4306 symbol match within the nest of blocks whose innermost member is BLOCK0,
4307 is the one match returned (no other matches in that or
4308 enclosing blocks is returned). If there are any matches in or
4309 surrounding BLOCK0, then these alone are returned. Otherwise, the
4310 search extends to global and file-scope (static) symbol tables.
4311 Names prefixed with "standard__" are handled specially: "standard__"
4312 is first stripped off, and only static and global symbols are searched. */
4315 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4316 domain_enum
namespace,
4317 struct ada_symbol_info
**results
)
4321 struct partial_symtab
*ps
;
4322 struct blockvector
*bv
;
4323 struct objfile
*objfile
;
4324 struct block
*block
;
4326 struct minimal_symbol
*msymbol
;
4332 obstack_free (&symbol_list_obstack
, NULL
);
4333 obstack_init (&symbol_list_obstack
);
4337 /* Search specified block and its superiors. */
4339 wild_match
= (strstr (name0
, "__") == NULL
);
4341 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4342 needed, but adding const will
4343 have a cascade effect. */
4344 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4348 name
= name0
+ sizeof ("standard__") - 1;
4352 while (block
!= NULL
)
4355 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4356 namespace, NULL
, NULL
, wild_match
);
4358 /* If we found a non-function match, assume that's the one. */
4359 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4360 num_defns_collected (&symbol_list_obstack
)))
4363 block
= BLOCK_SUPERBLOCK (block
);
4366 /* If no luck so far, try to find NAME as a local symbol in some lexically
4367 enclosing subprogram. */
4368 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4369 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4370 name
, namespace, wild_match
);
4372 /* If we found ANY matches among non-global symbols, we're done. */
4374 if (num_defns_collected (&symbol_list_obstack
) > 0)
4378 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4381 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4385 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4386 tables, and psymtab's. */
4388 ALL_SYMTABS (objfile
, s
)
4393 bv
= BLOCKVECTOR (s
);
4394 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4395 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4396 objfile
, s
, wild_match
);
4399 if (namespace == VAR_DOMAIN
)
4401 ALL_MSYMBOLS (objfile
, msymbol
)
4403 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4405 switch (MSYMBOL_TYPE (msymbol
))
4407 case mst_solib_trampoline
:
4410 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4413 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4415 bv
= BLOCKVECTOR (s
);
4416 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4417 ada_add_block_symbols (&symbol_list_obstack
, block
,
4418 SYMBOL_LINKAGE_NAME (msymbol
),
4419 namespace, objfile
, s
, wild_match
);
4421 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4423 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4424 ada_add_block_symbols (&symbol_list_obstack
, block
,
4425 SYMBOL_LINKAGE_NAME (msymbol
),
4426 namespace, objfile
, s
,
4435 ALL_PSYMTABS (objfile
, ps
)
4439 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4441 s
= PSYMTAB_TO_SYMTAB (ps
);
4444 bv
= BLOCKVECTOR (s
);
4445 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4446 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4447 namespace, objfile
, s
, wild_match
);
4451 /* Now add symbols from all per-file blocks if we've gotten no hits
4452 (Not strictly correct, but perhaps better than an error).
4453 Do the symtabs first, then check the psymtabs. */
4455 if (num_defns_collected (&symbol_list_obstack
) == 0)
4458 ALL_SYMTABS (objfile
, s
)
4463 bv
= BLOCKVECTOR (s
);
4464 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4465 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4466 objfile
, s
, wild_match
);
4469 ALL_PSYMTABS (objfile
, ps
)
4473 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4475 s
= PSYMTAB_TO_SYMTAB (ps
);
4476 bv
= BLOCKVECTOR (s
);
4479 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4480 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4481 namespace, objfile
, s
, wild_match
);
4487 ndefns
= num_defns_collected (&symbol_list_obstack
);
4488 *results
= defns_collected (&symbol_list_obstack
, 1);
4490 ndefns
= remove_extra_symbols (*results
, ndefns
);
4493 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4495 if (ndefns
== 1 && cacheIfUnique
)
4496 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4497 (*results
)[0].symtab
);
4499 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4500 (struct block
*) block0
);
4505 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4506 scope and in global scopes, or NULL if none. NAME is folded and
4507 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4508 choosing the first symbol if there are multiple choices.
4509 *IS_A_FIELD_OF_THIS is set to 0 and *SYMTAB is set to the symbol
4510 table in which the symbol was found (in both cases, these
4511 assignments occur only if the pointers are non-null). */
4514 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4515 domain_enum
namespace, int *is_a_field_of_this
,
4516 struct symtab
**symtab
)
4518 struct ada_symbol_info
*candidates
;
4521 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4522 block0
, namespace, &candidates
);
4524 if (n_candidates
== 0)
4527 if (is_a_field_of_this
!= NULL
)
4528 *is_a_field_of_this
= 0;
4532 *symtab
= candidates
[0].symtab
;
4533 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4535 struct objfile
*objfile
;
4538 struct blockvector
*bv
;
4540 /* Search the list of symtabs for one which contains the
4541 address of the start of this block. */
4542 ALL_SYMTABS (objfile
, s
)
4544 bv
= BLOCKVECTOR (s
);
4545 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4546 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4547 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4550 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4552 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4556 return candidates
[0].sym
;
4559 static struct symbol
*
4560 ada_lookup_symbol_nonlocal (const char *name
,
4561 const char *linkage_name
,
4562 const struct block
*block
,
4563 const domain_enum domain
, struct symtab
**symtab
)
4565 if (linkage_name
== NULL
)
4566 linkage_name
= name
;
4567 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4572 /* True iff STR is a possible encoded suffix of a normal Ada name
4573 that is to be ignored for matching purposes. Suffixes of parallel
4574 names (e.g., XVE) are not included here. Currently, the possible suffixes
4575 are given by either of the regular expression:
4577 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4579 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4580 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
4584 is_name_suffix (const char *str
)
4587 const char *matching
;
4588 const int len
= strlen (str
);
4590 /* (__[0-9]+)?\.[0-9]+ */
4592 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4595 while (isdigit (matching
[0]))
4597 if (matching
[0] == '\0')
4601 if (matching
[0] == '.')
4604 while (isdigit (matching
[0]))
4606 if (matching
[0] == '\0')
4611 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4614 while (isdigit (matching
[0]))
4616 if (matching
[0] == '\0')
4620 /* ??? We should not modify STR directly, as we are doing below. This
4621 is fine in this case, but may become problematic later if we find
4622 that this alternative did not work, and want to try matching
4623 another one from the begining of STR. Since we modified it, we
4624 won't be able to find the begining of the string anymore! */
4628 while (str
[0] != '_' && str
[0] != '\0')
4630 if (str
[0] != 'n' && str
[0] != 'b')
4635 if (str
[0] == '\000')
4639 if (str
[1] != '_' || str
[2] == '\000')
4643 if (strcmp (str
+ 3, "JM") == 0)
4645 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
4646 the LJM suffix in favor of the JM one. But we will
4647 still accept LJM as a valid suffix for a reasonable
4648 amount of time, just to allow ourselves to debug programs
4649 compiled using an older version of GNAT. */
4650 if (strcmp (str
+ 3, "LJM") == 0)
4654 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4655 || str
[4] == 'U' || str
[4] == 'P')
4657 if (str
[4] == 'R' && str
[5] != 'T')
4661 if (!isdigit (str
[2]))
4663 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4664 if (!isdigit (str
[k
]) && str
[k
] != '_')
4668 if (str
[0] == '$' && isdigit (str
[1]))
4670 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4671 if (!isdigit (str
[k
]) && str
[k
] != '_')
4678 /* Return nonzero if the given string starts with a dot ('.')
4679 followed by zero or more digits.
4681 Note: brobecker/2003-11-10: A forward declaration has not been
4682 added at the begining of this file yet, because this function
4683 is only used to work around a problem found during wild matching
4684 when trying to match minimal symbol names against symbol names
4685 obtained from dwarf-2 data. This function is therefore currently
4686 only used in wild_match() and is likely to be deleted when the
4687 problem in dwarf-2 is fixed. */
4690 is_dot_digits_suffix (const char *str
)
4696 while (isdigit (str
[0]))
4698 return (str
[0] == '\0');
4701 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4702 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4703 informational suffixes of NAME (i.e., for which is_name_suffix is
4707 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4713 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4714 stored in the symbol table for nested function names is sometimes
4715 different from the name of the associated entity stored in
4716 the dwarf-2 data: This is the case for nested subprograms, where
4717 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4718 while the symbol name from the dwarf-2 data does not.
4720 Although the DWARF-2 standard documents that entity names stored
4721 in the dwarf-2 data should be identical to the name as seen in
4722 the source code, GNAT takes a different approach as we already use
4723 a special encoding mechanism to convey the information so that
4724 a C debugger can still use the information generated to debug
4725 Ada programs. A corollary is that the symbol names in the dwarf-2
4726 data should match the names found in the symbol table. I therefore
4727 consider this issue as a compiler defect.
4729 Until the compiler is properly fixed, we work-around the problem
4730 by ignoring such suffixes during the match. We do so by making
4731 a copy of PATN0 and NAME0, and then by stripping such a suffix
4732 if present. We then perform the match on the resulting strings. */
4735 name_len
= strlen (name0
);
4737 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4738 strcpy (name
, name0
);
4739 dot
= strrchr (name
, '.');
4740 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4743 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4744 strncpy (patn
, patn0
, patn_len
);
4745 patn
[patn_len
] = '\0';
4746 dot
= strrchr (patn
, '.');
4747 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4750 patn_len
= dot
- patn
;
4754 /* Now perform the wild match. */
4756 name_len
= strlen (name
);
4757 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4758 && strncmp (patn
, name
+ 5, patn_len
) == 0
4759 && is_name_suffix (name
+ patn_len
+ 5))
4762 while (name_len
>= patn_len
)
4764 if (strncmp (patn
, name
, patn_len
) == 0
4765 && is_name_suffix (name
+ patn_len
))
4773 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4778 if (!islower (name
[2]))
4785 if (!islower (name
[1]))
4796 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4797 vector *defn_symbols, updating the list of symbols in OBSTACKP
4798 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4799 OBJFILE is the section containing BLOCK.
4800 SYMTAB is recorded with each symbol added. */
4803 ada_add_block_symbols (struct obstack
*obstackp
,
4804 struct block
*block
, const char *name
,
4805 domain_enum domain
, struct objfile
*objfile
,
4806 struct symtab
*symtab
, int wild
)
4808 struct dict_iterator iter
;
4809 int name_len
= strlen (name
);
4810 /* A matching argument symbol, if any. */
4811 struct symbol
*arg_sym
;
4812 /* Set true when we find a matching non-argument symbol. */
4821 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4823 if (SYMBOL_DOMAIN (sym
) == domain
4824 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
4826 switch (SYMBOL_CLASS (sym
))
4832 case LOC_REGPARM_ADDR
:
4833 case LOC_BASEREG_ARG
:
4834 case LOC_COMPUTED_ARG
:
4837 case LOC_UNRESOLVED
:
4841 add_defn_to_vec (obstackp
,
4842 fixup_symbol_section (sym
, objfile
),
4851 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4853 if (SYMBOL_DOMAIN (sym
) == domain
)
4855 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
4857 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
4859 switch (SYMBOL_CLASS (sym
))
4865 case LOC_REGPARM_ADDR
:
4866 case LOC_BASEREG_ARG
:
4867 case LOC_COMPUTED_ARG
:
4870 case LOC_UNRESOLVED
:
4874 add_defn_to_vec (obstackp
,
4875 fixup_symbol_section (sym
, objfile
),
4884 if (!found_sym
&& arg_sym
!= NULL
)
4886 add_defn_to_vec (obstackp
,
4887 fixup_symbol_section (arg_sym
, objfile
),
4896 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4898 if (SYMBOL_DOMAIN (sym
) == domain
)
4902 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
4905 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
4907 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
4912 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
4914 switch (SYMBOL_CLASS (sym
))
4920 case LOC_REGPARM_ADDR
:
4921 case LOC_BASEREG_ARG
:
4922 case LOC_COMPUTED_ARG
:
4925 case LOC_UNRESOLVED
:
4929 add_defn_to_vec (obstackp
,
4930 fixup_symbol_section (sym
, objfile
),
4938 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4939 They aren't parameters, right? */
4940 if (!found_sym
&& arg_sym
!= NULL
)
4942 add_defn_to_vec (obstackp
,
4943 fixup_symbol_section (arg_sym
, objfile
),
4951 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
4952 to be invisible to users. */
4955 ada_is_ignored_field (struct type
*type
, int field_num
)
4957 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
4961 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
4962 return (name
== NULL
4963 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
4967 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
4968 pointer or reference type whose ultimate target has a tag field. */
4971 ada_is_tagged_type (struct type
*type
, int refok
)
4973 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
4976 /* True iff TYPE represents the type of X'Tag */
4979 ada_is_tag_type (struct type
*type
)
4981 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
4985 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
4986 return (name
!= NULL
4987 && strcmp (name
, "ada__tags__dispatch_table") == 0);
4991 /* The type of the tag on VAL. */
4994 ada_tag_type (struct value
*val
)
4996 return ada_lookup_struct_elt_type (value_type (val
), "_tag", 1, 0, NULL
);
4999 /* The value of the tag on VAL. */
5002 ada_value_tag (struct value
*val
)
5004 return ada_value_struct_elt (val
, "_tag", "record");
5007 /* The value of the tag on the object of type TYPE whose contents are
5008 saved at VALADDR, if it is non-null, or is at memory address
5011 static struct value
*
5012 value_tag_from_contents_and_address (struct type
*type
,
5013 const gdb_byte
*valaddr
,
5016 int tag_byte_offset
, dummy1
, dummy2
;
5017 struct type
*tag_type
;
5018 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
5021 const gdb_byte
*valaddr1
= ((valaddr
== NULL
)
5023 : valaddr
+ tag_byte_offset
);
5024 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
5026 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
5031 static struct type
*
5032 type_from_tag (struct value
*tag
)
5034 const char *type_name
= ada_tag_name (tag
);
5035 if (type_name
!= NULL
)
5036 return ada_find_any_type (ada_encode (type_name
));
5046 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
5047 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
5048 The value stored in ARGS->name is valid until the next call to
5052 ada_tag_name_1 (void *args0
)
5054 struct tag_args
*args
= (struct tag_args
*) args0
;
5055 static char name
[1024];
5059 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
5062 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
5065 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
5066 for (p
= name
; *p
!= '\0'; p
+= 1)
5073 /* The type name of the dynamic type denoted by the 'tag value TAG, as
5077 ada_tag_name (struct value
*tag
)
5079 struct tag_args args
;
5080 if (!ada_is_tag_type (value_type (tag
)))
5084 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
5088 /* The parent type of TYPE, or NULL if none. */
5091 ada_parent_type (struct type
*type
)
5095 type
= ada_check_typedef (type
);
5097 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5100 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5101 if (ada_is_parent_field (type
, i
))
5102 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5107 /* True iff field number FIELD_NUM of structure type TYPE contains the
5108 parent-type (inherited) fields of a derived type. Assumes TYPE is
5109 a structure type with at least FIELD_NUM+1 fields. */
5112 ada_is_parent_field (struct type
*type
, int field_num
)
5114 const char *name
= TYPE_FIELD_NAME (ada_check_typedef (type
), field_num
);
5115 return (name
!= NULL
5116 && (strncmp (name
, "PARENT", 6) == 0
5117 || strncmp (name
, "_parent", 7) == 0));
5120 /* True iff field number FIELD_NUM of structure type TYPE is a
5121 transparent wrapper field (which should be silently traversed when doing
5122 field selection and flattened when printing). Assumes TYPE is a
5123 structure type with at least FIELD_NUM+1 fields. Such fields are always
5127 ada_is_wrapper_field (struct type
*type
, int field_num
)
5129 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5130 return (name
!= NULL
5131 && (strncmp (name
, "PARENT", 6) == 0
5132 || strcmp (name
, "REP") == 0
5133 || strncmp (name
, "_parent", 7) == 0
5134 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5137 /* True iff field number FIELD_NUM of structure or union type TYPE
5138 is a variant wrapper. Assumes TYPE is a structure type with at least
5139 FIELD_NUM+1 fields. */
5142 ada_is_variant_part (struct type
*type
, int field_num
)
5144 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5145 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5146 || (is_dynamic_field (type
, field_num
)
5147 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type
))
5148 == TYPE_CODE_UNION
)));
5151 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5152 whose discriminants are contained in the record type OUTER_TYPE,
5153 returns the type of the controlling discriminant for the variant. */
5156 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5158 char *name
= ada_variant_discrim_name (var_type
);
5160 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
5162 return builtin_type_int
;
5167 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5168 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5169 represents a 'when others' clause; otherwise 0. */
5172 ada_is_others_clause (struct type
*type
, int field_num
)
5174 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5175 return (name
!= NULL
&& name
[0] == 'O');
5178 /* Assuming that TYPE0 is the type of the variant part of a record,
5179 returns the name of the discriminant controlling the variant.
5180 The value is valid until the next call to ada_variant_discrim_name. */
5183 ada_variant_discrim_name (struct type
*type0
)
5185 static char *result
= NULL
;
5186 static size_t result_len
= 0;
5189 const char *discrim_end
;
5190 const char *discrim_start
;
5192 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5193 type
= TYPE_TARGET_TYPE (type0
);
5197 name
= ada_type_name (type
);
5199 if (name
== NULL
|| name
[0] == '\000')
5202 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5205 if (strncmp (discrim_end
, "___XVN", 6) == 0)
5208 if (discrim_end
== name
)
5211 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5214 if (discrim_start
== name
+ 1)
5216 if ((discrim_start
> name
+ 3
5217 && strncmp (discrim_start
- 3, "___", 3) == 0)
5218 || discrim_start
[-1] == '.')
5222 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5223 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5224 result
[discrim_end
- discrim_start
] = '\0';
5228 /* Scan STR for a subtype-encoded number, beginning at position K.
5229 Put the position of the character just past the number scanned in
5230 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
5231 Return 1 if there was a valid number at the given position, and 0
5232 otherwise. A "subtype-encoded" number consists of the absolute value
5233 in decimal, followed by the letter 'm' to indicate a negative number.
5234 Assumes 0m does not occur. */
5237 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5241 if (!isdigit (str
[k
]))
5244 /* Do it the hard way so as not to make any assumption about
5245 the relationship of unsigned long (%lu scan format code) and
5248 while (isdigit (str
[k
]))
5250 RU
= RU
* 10 + (str
[k
] - '0');
5257 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5263 /* NOTE on the above: Technically, C does not say what the results of
5264 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5265 number representable as a LONGEST (although either would probably work
5266 in most implementations). When RU>0, the locution in the then branch
5267 above is always equivalent to the negative of RU. */
5274 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5275 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5276 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5279 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5281 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5294 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5303 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5304 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5306 if (val
>= L
&& val
<= U
)
5318 /* FIXME: Lots of redundancy below. Try to consolidate. */
5320 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
5321 ARG_TYPE, extract and return the value of one of its (non-static)
5322 fields. FIELDNO says which field. Differs from value_primitive_field
5323 only in that it can handle packed values of arbitrary type. */
5325 static struct value
*
5326 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5327 struct type
*arg_type
)
5331 arg_type
= ada_check_typedef (arg_type
);
5332 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5334 /* Handle packed fields. */
5336 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5338 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5339 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5341 return ada_value_primitive_packed_val (arg1
, value_contents (arg1
),
5342 offset
+ bit_pos
/ 8,
5343 bit_pos
% 8, bit_size
, type
);
5346 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5349 /* Find field with name NAME in object of type TYPE. If found, return 1
5350 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
5351 OFFSET + the byte offset of the field within an object of that type,
5352 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
5353 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
5354 Looks inside wrappers for the field. Returns 0 if field not
5357 find_struct_field (char *name
, struct type
*type
, int offset
,
5358 struct type
**field_type_p
,
5359 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
5363 type
= ada_check_typedef (type
);
5364 *field_type_p
= NULL
;
5365 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
5367 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5369 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
5370 int fld_offset
= offset
+ bit_pos
/ 8;
5371 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5373 if (t_field_name
== NULL
)
5376 else if (field_name_match (t_field_name
, name
))
5378 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
5379 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
5380 *byte_offset_p
= fld_offset
;
5381 *bit_offset_p
= bit_pos
% 8;
5382 *bit_size_p
= bit_size
;
5385 else if (ada_is_wrapper_field (type
, i
))
5387 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
5388 field_type_p
, byte_offset_p
, bit_offset_p
,
5392 else if (ada_is_variant_part (type
, i
))
5395 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5397 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5399 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
5401 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5402 field_type_p
, byte_offset_p
,
5403 bit_offset_p
, bit_size_p
))
5413 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5414 and search in it assuming it has (class) type TYPE.
5415 If found, return value, else return NULL.
5417 Searches recursively through wrapper fields (e.g., '_parent'). */
5419 static struct value
*
5420 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5424 type
= ada_check_typedef (type
);
5426 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5428 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5430 if (t_field_name
== NULL
)
5433 else if (field_name_match (t_field_name
, name
))
5434 return ada_value_primitive_field (arg
, offset
, i
, type
);
5436 else if (ada_is_wrapper_field (type
, i
))
5438 struct value
*v
= /* Do not let indent join lines here. */
5439 ada_search_struct_field (name
, arg
,
5440 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
5441 TYPE_FIELD_TYPE (type
, i
));
5446 else if (ada_is_variant_part (type
, i
))
5449 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5450 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5452 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5454 struct value
*v
= ada_search_struct_field
/* Force line break. */
5456 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
5457 TYPE_FIELD_TYPE (field_type
, j
));
5466 /* Given ARG, a value of type (pointer or reference to a)*
5467 structure/union, extract the component named NAME from the ultimate
5468 target structure/union and return it as a value with its
5469 appropriate type. If ARG is a pointer or reference and the field
5470 is not packed, returns a reference to the field, otherwise the
5471 value of the field (an lvalue if ARG is an lvalue).
5473 The routine searches for NAME among all members of the structure itself
5474 and (recursively) among all members of any wrapper members
5477 ERR is a name (for use in error messages) that identifies the class
5478 of entity that ARG is supposed to be. ERR may be null, indicating
5479 that on error, the function simply returns NULL, and does not
5480 throw an error. (FIXME: True only if ARG is a pointer or reference
5484 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5486 struct type
*t
, *t1
;
5490 t1
= t
= ada_check_typedef (value_type (arg
));
5491 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
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
= coerce_ref (arg
);
5509 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5511 t1
= TYPE_TARGET_TYPE (t
);
5517 error (_("Bad value type in a %s."), err
);
5519 t1
= ada_check_typedef (t1
);
5520 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
5522 arg
= value_ind (arg
);
5529 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
5534 error (_("Attempt to extract a component of a value that is not a %s."),
5539 v
= ada_search_struct_field (name
, arg
, 0, t
);
5542 int bit_offset
, bit_size
, byte_offset
;
5543 struct type
*field_type
;
5546 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
5547 address
= value_as_address (arg
);
5549 address
= unpack_pointer (t
, value_contents (arg
));
5551 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
5552 if (find_struct_field (name
, t1
, 0,
5553 &field_type
, &byte_offset
, &bit_offset
,
5558 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
5559 arg
= ada_coerce_ref (arg
);
5561 arg
= ada_value_ind (arg
);
5562 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
5563 bit_offset
, bit_size
,
5567 v
= value_from_pointer (lookup_reference_type (field_type
),
5568 address
+ byte_offset
);
5572 if (v
== NULL
&& err
!= NULL
)
5573 error (_("There is no member named %s."), name
);
5578 /* Given a type TYPE, look up the type of the component of type named NAME.
5579 If DISPP is non-null, add its byte displacement from the beginning of a
5580 structure (pointed to by a value) of type TYPE to *DISPP (does not
5581 work for packed fields).
5583 Matches any field whose name has NAME as a prefix, possibly
5586 TYPE can be either a struct or union. If REFOK, TYPE may also
5587 be a (pointer or reference)+ to a struct or union, and the
5588 ultimate target type will be searched.
5590 Looks recursively into variant clauses and parent types.
5592 If NOERR is nonzero, return NULL if NAME is not suitably defined or
5593 TYPE is not a type of the right kind. */
5595 static struct type
*
5596 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
5597 int noerr
, int *dispp
)
5604 if (refok
&& type
!= NULL
)
5607 type
= ada_check_typedef (type
);
5608 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5609 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5611 type
= TYPE_TARGET_TYPE (type
);
5615 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
5616 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
5622 target_terminal_ours ();
5623 gdb_flush (gdb_stdout
);
5625 error (_("Type (null) is not a structure or union type"));
5628 /* XXX: type_sprint */
5629 fprintf_unfiltered (gdb_stderr
, _("Type "));
5630 type_print (type
, "", gdb_stderr
, -1);
5631 error (_(" is not a structure or union type"));
5636 type
= to_static_fixed_type (type
);
5638 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5640 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5644 if (t_field_name
== NULL
)
5647 else if (field_name_match (t_field_name
, name
))
5650 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5651 return ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5654 else if (ada_is_wrapper_field (type
, i
))
5657 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5662 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5667 else if (ada_is_variant_part (type
, i
))
5670 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type
, i
));
5672 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5675 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5680 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5691 target_terminal_ours ();
5692 gdb_flush (gdb_stdout
);
5695 /* XXX: type_sprint */
5696 fprintf_unfiltered (gdb_stderr
, _("Type "));
5697 type_print (type
, "", gdb_stderr
, -1);
5698 error (_(" has no component named <null>"));
5702 /* XXX: type_sprint */
5703 fprintf_unfiltered (gdb_stderr
, _("Type "));
5704 type_print (type
, "", gdb_stderr
, -1);
5705 error (_(" has no component named %s"), name
);
5712 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5713 within a value of type OUTER_TYPE that is stored in GDB at
5714 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5715 numbering from 0) is applicable. Returns -1 if none are. */
5718 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5719 const gdb_byte
*outer_valaddr
)
5724 struct type
*discrim_type
;
5725 char *discrim_name
= ada_variant_discrim_name (var_type
);
5726 LONGEST discrim_val
;
5730 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
5731 if (discrim_type
== NULL
)
5733 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5736 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5738 if (ada_is_others_clause (var_type
, i
))
5740 else if (ada_in_variant (discrim_val
, var_type
, i
))
5744 return others_clause
;
5749 /* Dynamic-Sized Records */
5751 /* Strategy: The type ostensibly attached to a value with dynamic size
5752 (i.e., a size that is not statically recorded in the debugging
5753 data) does not accurately reflect the size or layout of the value.
5754 Our strategy is to convert these values to values with accurate,
5755 conventional types that are constructed on the fly. */
5757 /* There is a subtle and tricky problem here. In general, we cannot
5758 determine the size of dynamic records without its data. However,
5759 the 'struct value' data structure, which GDB uses to represent
5760 quantities in the inferior process (the target), requires the size
5761 of the type at the time of its allocation in order to reserve space
5762 for GDB's internal copy of the data. That's why the
5763 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5764 rather than struct value*s.
5766 However, GDB's internal history variables ($1, $2, etc.) are
5767 struct value*s containing internal copies of the data that are not, in
5768 general, the same as the data at their corresponding addresses in
5769 the target. Fortunately, the types we give to these values are all
5770 conventional, fixed-size types (as per the strategy described
5771 above), so that we don't usually have to perform the
5772 'to_fixed_xxx_type' conversions to look at their values.
5773 Unfortunately, there is one exception: if one of the internal
5774 history variables is an array whose elements are unconstrained
5775 records, then we will need to create distinct fixed types for each
5776 element selected. */
5778 /* The upshot of all of this is that many routines take a (type, host
5779 address, target address) triple as arguments to represent a value.
5780 The host address, if non-null, is supposed to contain an internal
5781 copy of the relevant data; otherwise, the program is to consult the
5782 target at the target address. */
5784 /* Assuming that VAL0 represents a pointer value, the result of
5785 dereferencing it. Differs from value_ind in its treatment of
5786 dynamic-sized types. */
5789 ada_value_ind (struct value
*val0
)
5791 struct value
*val
= unwrap_value (value_ind (val0
));
5792 return ada_to_fixed_value (val
);
5795 /* The value resulting from dereferencing any "reference to"
5796 qualifiers on VAL0. */
5798 static struct value
*
5799 ada_coerce_ref (struct value
*val0
)
5801 if (TYPE_CODE (value_type (val0
)) == TYPE_CODE_REF
)
5803 struct value
*val
= val0
;
5804 val
= coerce_ref (val
);
5805 val
= unwrap_value (val
);
5806 return ada_to_fixed_value (val
);
5812 /* Return OFF rounded upward if necessary to a multiple of
5813 ALIGNMENT (a power of 2). */
5816 align_value (unsigned int off
, unsigned int alignment
)
5818 return (off
+ alignment
- 1) & ~(alignment
- 1);
5821 /* Return the bit alignment required for field #F of template type TYPE. */
5824 field_alignment (struct type
*type
, int f
)
5826 const char *name
= TYPE_FIELD_NAME (type
, f
);
5827 int len
= (name
== NULL
) ? 0 : strlen (name
);
5830 if (!isdigit (name
[len
- 1]))
5833 if (isdigit (name
[len
- 2]))
5834 align_offset
= len
- 2;
5836 align_offset
= len
- 1;
5838 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
5839 return TARGET_CHAR_BIT
;
5841 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5844 /* Find a symbol named NAME. Ignores ambiguity. */
5847 ada_find_any_symbol (const char *name
)
5851 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
5852 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5855 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
5859 /* Find a type named NAME. Ignores ambiguity. */
5862 ada_find_any_type (const char *name
)
5864 struct symbol
*sym
= ada_find_any_symbol (name
);
5867 return SYMBOL_TYPE (sym
);
5872 /* Given a symbol NAME and its associated BLOCK, search all symbols
5873 for its ___XR counterpart, which is the ``renaming'' symbol
5874 associated to NAME. Return this symbol if found, return
5878 ada_find_renaming_symbol (const char *name
, struct block
*block
)
5880 const struct symbol
*function_sym
= block_function (block
);
5883 if (function_sym
!= NULL
)
5885 /* If the symbol is defined inside a function, NAME is not fully
5886 qualified. This means we need to prepend the function name
5887 as well as adding the ``___XR'' suffix to build the name of
5888 the associated renaming symbol. */
5889 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
5890 const int function_name_len
= strlen (function_name
);
5891 const int rename_len
= function_name_len
+ 2 /* "__" */
5892 + strlen (name
) + 6 /* "___XR\0" */ ;
5894 /* Library-level functions are a special case, as GNAT adds
5895 a ``_ada_'' prefix to the function name to avoid namespace
5896 pollution. However, the renaming symbol themselves do not
5897 have this prefix, so we need to skip this prefix if present. */
5898 if (function_name_len
> 5 /* "_ada_" */
5899 && strstr (function_name
, "_ada_") == function_name
)
5900 function_name
= function_name
+ 5;
5902 rename
= (char *) alloca (rename_len
* sizeof (char));
5903 sprintf (rename
, "%s__%s___XR", function_name
, name
);
5907 const int rename_len
= strlen (name
) + 6;
5908 rename
= (char *) alloca (rename_len
* sizeof (char));
5909 sprintf (rename
, "%s___XR", name
);
5912 return ada_find_any_symbol (rename
);
5915 /* Because of GNAT encoding conventions, several GDB symbols may match a
5916 given type name. If the type denoted by TYPE0 is to be preferred to
5917 that of TYPE1 for purposes of type printing, return non-zero;
5918 otherwise return 0. */
5921 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5925 else if (type0
== NULL
)
5927 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5929 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5931 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
5933 else if (ada_is_packed_array_type (type0
))
5935 else if (ada_is_array_descriptor_type (type0
)
5936 && !ada_is_array_descriptor_type (type1
))
5938 else if (ada_renaming_type (type0
) != NULL
5939 && ada_renaming_type (type1
) == NULL
)
5944 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5945 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5948 ada_type_name (struct type
*type
)
5952 else if (TYPE_NAME (type
) != NULL
)
5953 return TYPE_NAME (type
);
5955 return TYPE_TAG_NAME (type
);
5958 /* Find a parallel type to TYPE whose name is formed by appending
5959 SUFFIX to the name of TYPE. */
5962 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5965 static size_t name_len
= 0;
5967 char *typename
= ada_type_name (type
);
5969 if (typename
== NULL
)
5972 len
= strlen (typename
);
5974 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5976 strcpy (name
, typename
);
5977 strcpy (name
+ len
, suffix
);
5979 return ada_find_any_type (name
);
5983 /* If TYPE is a variable-size record type, return the corresponding template
5984 type describing its fields. Otherwise, return NULL. */
5986 static struct type
*
5987 dynamic_template_type (struct type
*type
)
5989 type
= ada_check_typedef (type
);
5991 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5992 || ada_type_name (type
) == NULL
)
5996 int len
= strlen (ada_type_name (type
));
5997 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
6000 return ada_find_parallel_type (type
, "___XVE");
6004 /* Assuming that TEMPL_TYPE is a union or struct type, returns
6005 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
6008 is_dynamic_field (struct type
*templ_type
, int field_num
)
6010 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
6012 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
6013 && strstr (name
, "___XVL") != NULL
;
6016 /* The index of the variant field of TYPE, or -1 if TYPE does not
6017 represent a variant record type. */
6020 variant_field_index (struct type
*type
)
6024 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6027 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
6029 if (ada_is_variant_part (type
, f
))
6035 /* A record type with no fields. */
6037 static struct type
*
6038 empty_record (struct objfile
*objfile
)
6040 struct type
*type
= alloc_type (objfile
);
6041 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
6042 TYPE_NFIELDS (type
) = 0;
6043 TYPE_FIELDS (type
) = NULL
;
6044 TYPE_NAME (type
) = "<empty>";
6045 TYPE_TAG_NAME (type
) = NULL
;
6046 TYPE_FLAGS (type
) = 0;
6047 TYPE_LENGTH (type
) = 0;
6051 /* An ordinary record type (with fixed-length fields) that describes
6052 the value of type TYPE at VALADDR or ADDRESS (see comments at
6053 the beginning of this section) VAL according to GNAT conventions.
6054 DVAL0 should describe the (portion of a) record that contains any
6055 necessary discriminants. It should be NULL if value_type (VAL) is
6056 an outer-level type (i.e., as opposed to a branch of a variant.) A
6057 variant field (unless unchecked) is replaced by a particular branch
6060 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
6061 length are not statically known are discarded. As a consequence,
6062 VALADDR, ADDRESS and DVAL0 are ignored.
6064 NOTE: Limitations: For now, we assume that dynamic fields and
6065 variants occupy whole numbers of bytes. However, they need not be
6069 ada_template_to_fixed_record_type_1 (struct type
*type
,
6070 const gdb_byte
*valaddr
,
6071 CORE_ADDR address
, struct value
*dval0
,
6072 int keep_dynamic_fields
)
6074 struct value
*mark
= value_mark ();
6077 int nfields
, bit_len
;
6080 int fld_bit_len
, bit_incr
;
6083 /* Compute the number of fields in this record type that are going
6084 to be processed: unless keep_dynamic_fields, this includes only
6085 fields whose position and length are static will be processed. */
6086 if (keep_dynamic_fields
)
6087 nfields
= TYPE_NFIELDS (type
);
6091 while (nfields
< TYPE_NFIELDS (type
)
6092 && !ada_is_variant_part (type
, nfields
)
6093 && !is_dynamic_field (type
, nfields
))
6097 rtype
= alloc_type (TYPE_OBJFILE (type
));
6098 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6099 INIT_CPLUS_SPECIFIC (rtype
);
6100 TYPE_NFIELDS (rtype
) = nfields
;
6101 TYPE_FIELDS (rtype
) = (struct field
*)
6102 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6103 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
6104 TYPE_NAME (rtype
) = ada_type_name (type
);
6105 TYPE_TAG_NAME (rtype
) = NULL
;
6106 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6112 for (f
= 0; f
< nfields
; f
+= 1)
6114 off
= align_value (off
, field_alignment (type
, f
))
6115 + TYPE_FIELD_BITPOS (type
, f
);
6116 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
6117 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
6119 if (ada_is_variant_part (type
, f
))
6122 fld_bit_len
= bit_incr
= 0;
6124 else if (is_dynamic_field (type
, f
))
6127 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6131 TYPE_FIELD_TYPE (rtype
, f
) =
6134 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6135 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6136 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6137 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6138 bit_incr
= fld_bit_len
=
6139 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6143 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6144 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6145 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6146 bit_incr
= fld_bit_len
=
6147 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6149 bit_incr
= fld_bit_len
=
6150 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6152 if (off
+ fld_bit_len
> bit_len
)
6153 bit_len
= off
+ fld_bit_len
;
6155 TYPE_LENGTH (rtype
) =
6156 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6159 /* We handle the variant part, if any, at the end because of certain
6160 odd cases in which it is re-ordered so as NOT the last field of
6161 the record. This can happen in the presence of representation
6163 if (variant_field
>= 0)
6165 struct type
*branch_type
;
6167 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
6170 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6175 to_fixed_variant_branch_type
6176 (TYPE_FIELD_TYPE (type
, variant_field
),
6177 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6178 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6179 if (branch_type
== NULL
)
6181 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
6182 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6183 TYPE_NFIELDS (rtype
) -= 1;
6187 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6188 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6190 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
6192 if (off
+ fld_bit_len
> bit_len
)
6193 bit_len
= off
+ fld_bit_len
;
6194 TYPE_LENGTH (rtype
) =
6195 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
6199 /* According to exp_dbug.ads, the size of TYPE for variable-size records
6200 should contain the alignment of that record, which should be a strictly
6201 positive value. If null or negative, then something is wrong, most
6202 probably in the debug info. In that case, we don't round up the size
6203 of the resulting type. If this record is not part of another structure,
6204 the current RTYPE length might be good enough for our purposes. */
6205 if (TYPE_LENGTH (type
) <= 0)
6207 if (TYPE_NAME (rtype
))
6208 warning (_("Invalid type size for `%s' detected: %d."),
6209 TYPE_NAME (rtype
), TYPE_LENGTH (type
));
6211 warning (_("Invalid type size for <unnamed> detected: %d."),
6212 TYPE_LENGTH (type
));
6216 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
),
6217 TYPE_LENGTH (type
));
6220 value_free_to_mark (mark
);
6221 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6222 error (_("record type with dynamic size is larger than varsize-limit"));
6226 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
6229 static struct type
*
6230 template_to_fixed_record_type (struct type
*type
, const gdb_byte
*valaddr
,
6231 CORE_ADDR address
, struct value
*dval0
)
6233 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
6237 /* An ordinary record type in which ___XVL-convention fields and
6238 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
6239 static approximations, containing all possible fields. Uses
6240 no runtime values. Useless for use in values, but that's OK,
6241 since the results are used only for type determinations. Works on both
6242 structs and unions. Representation note: to save space, we memorize
6243 the result of this function in the TYPE_TARGET_TYPE of the
6246 static struct type
*
6247 template_to_static_fixed_type (struct type
*type0
)
6253 if (TYPE_TARGET_TYPE (type0
) != NULL
)
6254 return TYPE_TARGET_TYPE (type0
);
6256 nfields
= TYPE_NFIELDS (type0
);
6259 for (f
= 0; f
< nfields
; f
+= 1)
6261 struct type
*field_type
= ada_check_typedef (TYPE_FIELD_TYPE (type0
, f
));
6262 struct type
*new_type
;
6264 if (is_dynamic_field (type0
, f
))
6265 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
6267 new_type
= to_static_fixed_type (field_type
);
6268 if (type
== type0
&& new_type
!= field_type
)
6270 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
6271 TYPE_CODE (type
) = TYPE_CODE (type0
);
6272 INIT_CPLUS_SPECIFIC (type
);
6273 TYPE_NFIELDS (type
) = nfields
;
6274 TYPE_FIELDS (type
) = (struct field
*)
6275 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6276 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
6277 sizeof (struct field
) * nfields
);
6278 TYPE_NAME (type
) = ada_type_name (type0
);
6279 TYPE_TAG_NAME (type
) = NULL
;
6280 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
6281 TYPE_LENGTH (type
) = 0;
6283 TYPE_FIELD_TYPE (type
, f
) = new_type
;
6284 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
6289 /* Given an object of type TYPE whose contents are at VALADDR and
6290 whose address in memory is ADDRESS, returns a revision of TYPE --
6291 a non-dynamic-sized record with a variant part -- in which
6292 the variant part is replaced with the appropriate branch. Looks
6293 for discriminant values in DVAL0, which can be NULL if the record
6294 contains the necessary discriminant values. */
6296 static struct type
*
6297 to_record_with_fixed_variant_part (struct type
*type
, const gdb_byte
*valaddr
,
6298 CORE_ADDR address
, struct value
*dval0
)
6300 struct value
*mark
= value_mark ();
6303 struct type
*branch_type
;
6304 int nfields
= TYPE_NFIELDS (type
);
6305 int variant_field
= variant_field_index (type
);
6307 if (variant_field
== -1)
6311 dval
= value_from_contents_and_address (type
, valaddr
, address
);
6315 rtype
= alloc_type (TYPE_OBJFILE (type
));
6316 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6317 INIT_CPLUS_SPECIFIC (rtype
);
6318 TYPE_NFIELDS (rtype
) = nfields
;
6319 TYPE_FIELDS (rtype
) =
6320 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6321 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6322 sizeof (struct field
) * nfields
);
6323 TYPE_NAME (rtype
) = ada_type_name (type
);
6324 TYPE_TAG_NAME (rtype
) = NULL
;
6325 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
6326 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6328 branch_type
= to_fixed_variant_branch_type
6329 (TYPE_FIELD_TYPE (type
, variant_field
),
6330 cond_offset_host (valaddr
,
6331 TYPE_FIELD_BITPOS (type
, variant_field
)
6333 cond_offset_target (address
,
6334 TYPE_FIELD_BITPOS (type
, variant_field
)
6335 / TARGET_CHAR_BIT
), dval
);
6336 if (branch_type
== NULL
)
6339 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
6340 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
6341 TYPE_NFIELDS (rtype
) -= 1;
6345 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
6346 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
6347 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
6348 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6350 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
6352 value_free_to_mark (mark
);
6356 /* An ordinary record type (with fixed-length fields) that describes
6357 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6358 beginning of this section]. Any necessary discriminants' values
6359 should be in DVAL, a record value; it may be NULL if the object
6360 at ADDR itself contains any necessary discriminant values.
6361 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
6362 values from the record are needed. Except in the case that DVAL,
6363 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
6364 unchecked) is replaced by a particular branch of the variant.
6366 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
6367 is questionable and may be removed. It can arise during the
6368 processing of an unconstrained-array-of-record type where all the
6369 variant branches have exactly the same size. This is because in
6370 such cases, the compiler does not bother to use the XVS convention
6371 when encoding the record. I am currently dubious of this
6372 shortcut and suspect the compiler should be altered. FIXME. */
6374 static struct type
*
6375 to_fixed_record_type (struct type
*type0
, const gdb_byte
*valaddr
,
6376 CORE_ADDR address
, struct value
*dval
)
6378 struct type
*templ_type
;
6380 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6383 templ_type
= dynamic_template_type (type0
);
6385 if (templ_type
!= NULL
)
6386 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6387 else if (variant_field_index (type0
) >= 0)
6389 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
6391 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
6396 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
6402 /* An ordinary record type (with fixed-length fields) that describes
6403 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6404 union type. Any necessary discriminants' values should be in DVAL,
6405 a record value. That is, this routine selects the appropriate
6406 branch of the union at ADDR according to the discriminant value
6407 indicated in the union's type name. */
6409 static struct type
*
6410 to_fixed_variant_branch_type (struct type
*var_type0
, const gdb_byte
*valaddr
,
6411 CORE_ADDR address
, struct value
*dval
)
6414 struct type
*templ_type
;
6415 struct type
*var_type
;
6417 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6418 var_type
= TYPE_TARGET_TYPE (var_type0
);
6420 var_type
= var_type0
;
6422 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6424 if (templ_type
!= NULL
)
6425 var_type
= templ_type
;
6428 ada_which_variant_applies (var_type
,
6429 value_type (dval
), value_contents (dval
));
6432 return empty_record (TYPE_OBJFILE (var_type
));
6433 else if (is_dynamic_field (var_type
, which
))
6434 return to_fixed_record_type
6435 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6436 valaddr
, address
, dval
);
6437 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
6439 to_fixed_record_type
6440 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6442 return TYPE_FIELD_TYPE (var_type
, which
);
6445 /* Assuming that TYPE0 is an array type describing the type of a value
6446 at ADDR, and that DVAL describes a record containing any
6447 discriminants used in TYPE0, returns a type for the value that
6448 contains no dynamic components (that is, no components whose sizes
6449 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6450 true, gives an error message if the resulting type's size is over
6453 static struct type
*
6454 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6457 struct type
*index_type_desc
;
6458 struct type
*result
;
6460 if (ada_is_packed_array_type (type0
) /* revisit? */
6461 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
6464 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6465 if (index_type_desc
== NULL
)
6467 struct type
*elt_type0
= ada_check_typedef (TYPE_TARGET_TYPE (type0
));
6468 /* NOTE: elt_type---the fixed version of elt_type0---should never
6469 depend on the contents of the array in properly constructed
6471 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6473 if (elt_type0
== elt_type
)
6476 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6477 elt_type
, TYPE_INDEX_TYPE (type0
));
6482 struct type
*elt_type0
;
6485 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6486 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6488 /* NOTE: result---the fixed version of elt_type0---should never
6489 depend on the contents of the array in properly constructed
6491 result
= ada_to_fixed_type (ada_check_typedef (elt_type0
), 0, 0, dval
);
6492 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6494 struct type
*range_type
=
6495 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6496 dval
, TYPE_OBJFILE (type0
));
6497 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6498 result
, range_type
);
6500 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6501 error (_("array type with dynamic size is larger than varsize-limit"));
6504 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
6509 /* A standard type (containing no dynamically sized components)
6510 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6511 DVAL describes a record containing any discriminants used in TYPE0,
6512 and may be NULL if there are none, or if the object of type TYPE at
6513 ADDRESS or in VALADDR contains these discriminants. */
6516 ada_to_fixed_type (struct type
*type
, const gdb_byte
*valaddr
,
6517 CORE_ADDR address
, struct value
*dval
)
6519 type
= ada_check_typedef (type
);
6520 switch (TYPE_CODE (type
))
6524 case TYPE_CODE_STRUCT
:
6526 struct type
*static_type
= to_static_fixed_type (type
);
6527 if (ada_is_tagged_type (static_type
, 0))
6529 struct type
*real_type
=
6530 type_from_tag (value_tag_from_contents_and_address (static_type
,
6533 if (real_type
!= NULL
)
6536 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6538 case TYPE_CODE_ARRAY
:
6539 return to_fixed_array_type (type
, dval
, 1);
6540 case TYPE_CODE_UNION
:
6544 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6548 /* A standard (static-sized) type corresponding as well as possible to
6549 TYPE0, but based on no runtime data. */
6551 static struct type
*
6552 to_static_fixed_type (struct type
*type0
)
6559 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
6562 type0
= ada_check_typedef (type0
);
6564 switch (TYPE_CODE (type0
))
6568 case TYPE_CODE_STRUCT
:
6569 type
= dynamic_template_type (type0
);
6571 return template_to_static_fixed_type (type
);
6573 return template_to_static_fixed_type (type0
);
6574 case TYPE_CODE_UNION
:
6575 type
= ada_find_parallel_type (type0
, "___XVU");
6577 return template_to_static_fixed_type (type
);
6579 return template_to_static_fixed_type (type0
);
6583 /* A static approximation of TYPE with all type wrappers removed. */
6585 static struct type
*
6586 static_unwrap_type (struct type
*type
)
6588 if (ada_is_aligner_type (type
))
6590 struct type
*type1
= TYPE_FIELD_TYPE (ada_check_typedef (type
), 0);
6591 if (ada_type_name (type1
) == NULL
)
6592 TYPE_NAME (type1
) = ada_type_name (type
);
6594 return static_unwrap_type (type1
);
6598 struct type
*raw_real_type
= ada_get_base_type (type
);
6599 if (raw_real_type
== type
)
6602 return to_static_fixed_type (raw_real_type
);
6606 /* In some cases, incomplete and private types require
6607 cross-references that are not resolved as records (for example,
6609 type FooP is access Foo;
6611 type Foo is array ...;
6612 ). In these cases, since there is no mechanism for producing
6613 cross-references to such types, we instead substitute for FooP a
6614 stub enumeration type that is nowhere resolved, and whose tag is
6615 the name of the actual type. Call these types "non-record stubs". */
6617 /* A type equivalent to TYPE that is not a non-record stub, if one
6618 exists, otherwise TYPE. */
6621 ada_check_typedef (struct type
*type
)
6623 CHECK_TYPEDEF (type
);
6624 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6625 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6626 || TYPE_TAG_NAME (type
) == NULL
)
6630 char *name
= TYPE_TAG_NAME (type
);
6631 struct type
*type1
= ada_find_any_type (name
);
6632 return (type1
== NULL
) ? type
: type1
;
6636 /* A value representing the data at VALADDR/ADDRESS as described by
6637 type TYPE0, but with a standard (static-sized) type that correctly
6638 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6639 type, then return VAL0 [this feature is simply to avoid redundant
6640 creation of struct values]. */
6642 static struct value
*
6643 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
6646 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
6647 if (type
== type0
&& val0
!= NULL
)
6650 return value_from_contents_and_address (type
, 0, address
);
6653 /* A value representing VAL, but with a standard (static-sized) type
6654 that correctly describes it. Does not necessarily create a new
6657 static struct value
*
6658 ada_to_fixed_value (struct value
*val
)
6660 return ada_to_fixed_value_create (value_type (val
),
6661 VALUE_ADDRESS (val
) + value_offset (val
),
6665 /* A value representing VAL, but with a standard (static-sized) type
6666 chosen to approximate the real type of VAL as well as possible, but
6667 without consulting any runtime values. For Ada dynamic-sized
6668 types, therefore, the type of the result is likely to be inaccurate. */
6671 ada_to_static_fixed_value (struct value
*val
)
6674 to_static_fixed_type (static_unwrap_type (value_type (val
)));
6675 if (type
== value_type (val
))
6678 return coerce_unspec_val_to_type (val
, type
);
6684 /* Table mapping attribute numbers to names.
6685 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
6687 static const char *attribute_names
[] = {
6705 ada_attribute_name (enum exp_opcode n
)
6707 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
6708 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
6710 return attribute_names
[0];
6713 /* Evaluate the 'POS attribute applied to ARG. */
6716 pos_atr (struct value
*arg
)
6718 struct type
*type
= value_type (arg
);
6720 if (!discrete_type_p (type
))
6721 error (_("'POS only defined on discrete types"));
6723 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6726 LONGEST v
= value_as_long (arg
);
6728 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6730 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6733 error (_("enumeration value is invalid: can't find 'POS"));
6736 return value_as_long (arg
);
6739 static struct value
*
6740 value_pos_atr (struct value
*arg
)
6742 return value_from_longest (builtin_type_int
, pos_atr (arg
));
6745 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6747 static struct value
*
6748 value_val_atr (struct type
*type
, struct value
*arg
)
6750 if (!discrete_type_p (type
))
6751 error (_("'VAL only defined on discrete types"));
6752 if (!integer_type_p (value_type (arg
)))
6753 error (_("'VAL requires integral argument"));
6755 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6757 long pos
= value_as_long (arg
);
6758 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6759 error (_("argument to 'VAL out of range"));
6760 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6763 return value_from_longest (type
, value_as_long (arg
));
6769 /* True if TYPE appears to be an Ada character type.
6770 [At the moment, this is true only for Character and Wide_Character;
6771 It is a heuristic test that could stand improvement]. */
6774 ada_is_character_type (struct type
*type
)
6776 const char *name
= ada_type_name (type
);
6779 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6780 || TYPE_CODE (type
) == TYPE_CODE_INT
6781 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6782 && (strcmp (name
, "character") == 0
6783 || strcmp (name
, "wide_character") == 0
6784 || strcmp (name
, "unsigned char") == 0);
6787 /* True if TYPE appears to be an Ada string type. */
6790 ada_is_string_type (struct type
*type
)
6792 type
= ada_check_typedef (type
);
6794 && TYPE_CODE (type
) != TYPE_CODE_PTR
6795 && (ada_is_simple_array_type (type
)
6796 || ada_is_array_descriptor_type (type
))
6797 && ada_array_arity (type
) == 1)
6799 struct type
*elttype
= ada_array_element_type (type
, 1);
6801 return ada_is_character_type (elttype
);
6808 /* True if TYPE is a struct type introduced by the compiler to force the
6809 alignment of a value. Such types have a single field with a
6810 distinctive name. */
6813 ada_is_aligner_type (struct type
*type
)
6815 type
= ada_check_typedef (type
);
6817 /* If we can find a parallel XVS type, then the XVS type should
6818 be used instead of this type. And hence, this is not an aligner
6820 if (ada_find_parallel_type (type
, "___XVS") != NULL
)
6823 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6824 && TYPE_NFIELDS (type
) == 1
6825 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
6828 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6829 the parallel type. */
6832 ada_get_base_type (struct type
*raw_type
)
6834 struct type
*real_type_namer
;
6835 struct type
*raw_real_type
;
6837 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6840 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6841 if (real_type_namer
== NULL
6842 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6843 || TYPE_NFIELDS (real_type_namer
) != 1)
6846 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6847 if (raw_real_type
== NULL
)
6850 return raw_real_type
;
6853 /* The type of value designated by TYPE, with all aligners removed. */
6856 ada_aligned_type (struct type
*type
)
6858 if (ada_is_aligner_type (type
))
6859 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6861 return ada_get_base_type (type
);
6865 /* The address of the aligned value in an object at address VALADDR
6866 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6869 ada_aligned_value_addr (struct type
*type
, const gdb_byte
*valaddr
)
6871 if (ada_is_aligner_type (type
))
6872 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6874 TYPE_FIELD_BITPOS (type
,
6875 0) / TARGET_CHAR_BIT
);
6882 /* The printed representation of an enumeration literal with encoded
6883 name NAME. The value is good to the next call of ada_enum_name. */
6885 ada_enum_name (const char *name
)
6887 static char *result
;
6888 static size_t result_len
= 0;
6891 /* First, unqualify the enumeration name:
6892 1. Search for the last '.' character. If we find one, then skip
6893 all the preceeding characters, the unqualified name starts
6894 right after that dot.
6895 2. Otherwise, we may be debugging on a target where the compiler
6896 translates dots into "__". Search forward for double underscores,
6897 but stop searching when we hit an overloading suffix, which is
6898 of the form "__" followed by digits. */
6900 tmp
= strrchr (name
, '.');
6905 while ((tmp
= strstr (name
, "__")) != NULL
)
6907 if (isdigit (tmp
[2]))
6917 if (name
[1] == 'U' || name
[1] == 'W')
6919 if (sscanf (name
+ 2, "%x", &v
) != 1)
6925 GROW_VECT (result
, result_len
, 16);
6926 if (isascii (v
) && isprint (v
))
6927 sprintf (result
, "'%c'", v
);
6928 else if (name
[1] == 'U')
6929 sprintf (result
, "[\"%02x\"]", v
);
6931 sprintf (result
, "[\"%04x\"]", v
);
6937 tmp
= strstr (name
, "__");
6939 tmp
= strstr (name
, "$");
6942 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
6943 strncpy (result
, name
, tmp
- name
);
6944 result
[tmp
- name
] = '\0';
6952 static struct value
*
6953 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6956 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6957 (expect_type
, exp
, pos
, noside
);
6960 /* Evaluate the subexpression of EXP starting at *POS as for
6961 evaluate_type, updating *POS to point just past the evaluated
6964 static struct value
*
6965 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6967 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
6968 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6971 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6974 static struct value
*
6975 unwrap_value (struct value
*val
)
6977 struct type
*type
= ada_check_typedef (value_type (val
));
6978 if (ada_is_aligner_type (type
))
6980 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6981 NULL
, "internal structure");
6982 struct type
*val_type
= ada_check_typedef (value_type (v
));
6983 if (ada_type_name (val_type
) == NULL
)
6984 TYPE_NAME (val_type
) = ada_type_name (type
);
6986 return unwrap_value (v
);
6990 struct type
*raw_real_type
=
6991 ada_check_typedef (ada_get_base_type (type
));
6993 if (type
== raw_real_type
)
6997 coerce_unspec_val_to_type
6998 (val
, ada_to_fixed_type (raw_real_type
, 0,
6999 VALUE_ADDRESS (val
) + value_offset (val
),
7004 static struct value
*
7005 cast_to_fixed (struct type
*type
, struct value
*arg
)
7009 if (type
== value_type (arg
))
7011 else if (ada_is_fixed_point_type (value_type (arg
)))
7012 val
= ada_float_to_fixed (type
,
7013 ada_fixed_to_float (value_type (arg
),
7014 value_as_long (arg
)));
7018 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
7019 val
= ada_float_to_fixed (type
, argd
);
7022 return value_from_longest (type
, val
);
7025 static struct value
*
7026 cast_from_fixed_to_double (struct value
*arg
)
7028 DOUBLEST val
= ada_fixed_to_float (value_type (arg
),
7029 value_as_long (arg
));
7030 return value_from_double (builtin_type_double
, val
);
7033 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
7034 return the converted value. */
7036 static struct value
*
7037 coerce_for_assign (struct type
*type
, struct value
*val
)
7039 struct type
*type2
= value_type (val
);
7043 type2
= ada_check_typedef (type2
);
7044 type
= ada_check_typedef (type
);
7046 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
7047 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7049 val
= ada_value_ind (val
);
7050 type2
= value_type (val
);
7053 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
7054 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7056 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
7057 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
7058 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
7059 error (_("Incompatible types in assignment"));
7060 deprecated_set_value_type (val
, type
);
7065 static struct value
*
7066 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
7069 struct type
*type1
, *type2
;
7072 arg1
= coerce_ref (arg1
);
7073 arg2
= coerce_ref (arg2
);
7074 type1
= base_type (ada_check_typedef (value_type (arg1
)));
7075 type2
= base_type (ada_check_typedef (value_type (arg2
)));
7077 if (TYPE_CODE (type1
) != TYPE_CODE_INT
7078 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
7079 return value_binop (arg1
, arg2
, op
);
7088 return value_binop (arg1
, arg2
, op
);
7091 v2
= value_as_long (arg2
);
7093 error (_("second operand of %s must not be zero."), op_string (op
));
7095 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
7096 return value_binop (arg1
, arg2
, op
);
7098 v1
= value_as_long (arg1
);
7103 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
7104 v
+= v
> 0 ? -1 : 1;
7112 /* Should not reach this point. */
7116 val
= allocate_value (type1
);
7117 store_unsigned_integer (value_contents_raw (val
),
7118 TYPE_LENGTH (value_type (val
)), v
);
7123 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
7125 if (ada_is_direct_array_type (value_type (arg1
))
7126 || ada_is_direct_array_type (value_type (arg2
)))
7128 arg1
= ada_coerce_to_simple_array (arg1
);
7129 arg2
= ada_coerce_to_simple_array (arg2
);
7130 if (TYPE_CODE (value_type (arg1
)) != TYPE_CODE_ARRAY
7131 || TYPE_CODE (value_type (arg2
)) != TYPE_CODE_ARRAY
)
7132 error (_("Attempt to compare array with non-array"));
7133 /* FIXME: The following works only for types whose
7134 representations use all bits (no padding or undefined bits)
7135 and do not have user-defined equality. */
7137 TYPE_LENGTH (value_type (arg1
)) == TYPE_LENGTH (value_type (arg2
))
7138 && memcmp (value_contents (arg1
), value_contents (arg2
),
7139 TYPE_LENGTH (value_type (arg1
))) == 0;
7141 return value_equal (arg1
, arg2
);
7145 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
7146 int *pos
, enum noside noside
)
7149 int tem
, tem2
, tem3
;
7151 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
7154 struct value
**argvec
;
7158 op
= exp
->elts
[pc
].opcode
;
7165 unwrap_value (evaluate_subexp_standard
7166 (expect_type
, exp
, pos
, noside
));
7170 struct value
*result
;
7172 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
7173 /* The result type will have code OP_STRING, bashed there from
7174 OP_ARRAY. Bash it back. */
7175 if (TYPE_CODE (value_type (result
)) == TYPE_CODE_STRING
)
7176 TYPE_CODE (value_type (result
)) = TYPE_CODE_ARRAY
;
7182 type
= exp
->elts
[pc
+ 1].type
;
7183 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
7184 if (noside
== EVAL_SKIP
)
7186 if (type
!= ada_check_typedef (value_type (arg1
)))
7188 if (ada_is_fixed_point_type (type
))
7189 arg1
= cast_to_fixed (type
, arg1
);
7190 else if (ada_is_fixed_point_type (value_type (arg1
)))
7191 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
7192 else if (VALUE_LVAL (arg1
) == lval_memory
)
7194 /* This is in case of the really obscure (and undocumented,
7195 but apparently expected) case of (Foo) Bar.all, where Bar
7196 is an integer constant and Foo is a dynamic-sized type.
7197 If we don't do this, ARG1 will simply be relabeled with
7199 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7200 return value_zero (to_static_fixed_type (type
), not_lval
);
7202 ada_to_fixed_value_create
7203 (type
, VALUE_ADDRESS (arg1
) + value_offset (arg1
), 0);
7206 arg1
= value_cast (type
, arg1
);
7212 type
= exp
->elts
[pc
+ 1].type
;
7213 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
7216 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7217 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7218 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7220 if (ada_is_fixed_point_type (value_type (arg1
)))
7221 arg2
= cast_to_fixed (value_type (arg1
), arg2
);
7222 else if (ada_is_fixed_point_type (value_type (arg2
)))
7224 (_("Fixed-point values must be assigned to fixed-point variables"));
7226 arg2
= coerce_for_assign (value_type (arg1
), arg2
);
7227 return ada_value_assign (arg1
, arg2
);
7230 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7231 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7232 if (noside
== EVAL_SKIP
)
7234 if ((ada_is_fixed_point_type (value_type (arg1
))
7235 || ada_is_fixed_point_type (value_type (arg2
)))
7236 && value_type (arg1
) != value_type (arg2
))
7237 error (_("Operands of fixed-point addition must have the same type"));
7238 return value_cast (value_type (arg1
), value_add (arg1
, arg2
));
7241 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7242 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
7243 if (noside
== EVAL_SKIP
)
7245 if ((ada_is_fixed_point_type (value_type (arg1
))
7246 || ada_is_fixed_point_type (value_type (arg2
)))
7247 && value_type (arg1
) != value_type (arg2
))
7248 error (_("Operands of fixed-point subtraction must have the same type"));
7249 return value_cast (value_type (arg1
), value_sub (arg1
, arg2
));
7253 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7254 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7255 if (noside
== EVAL_SKIP
)
7257 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7258 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7259 return value_zero (value_type (arg1
), not_lval
);
7262 if (ada_is_fixed_point_type (value_type (arg1
)))
7263 arg1
= cast_from_fixed_to_double (arg1
);
7264 if (ada_is_fixed_point_type (value_type (arg2
)))
7265 arg2
= cast_from_fixed_to_double (arg2
);
7266 return ada_value_binop (arg1
, arg2
, op
);
7271 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7272 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7273 if (noside
== EVAL_SKIP
)
7275 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
7276 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
7277 return value_zero (value_type (arg1
), not_lval
);
7279 return ada_value_binop (arg1
, arg2
, op
);
7282 case BINOP_NOTEQUAL
:
7283 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7284 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
7285 if (noside
== EVAL_SKIP
)
7287 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7290 tem
= ada_value_equal (arg1
, arg2
);
7291 if (op
== BINOP_NOTEQUAL
)
7293 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
7296 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7297 if (noside
== EVAL_SKIP
)
7299 else if (ada_is_fixed_point_type (value_type (arg1
)))
7300 return value_cast (value_type (arg1
), value_neg (arg1
));
7302 return value_neg (arg1
);
7306 if (noside
== EVAL_SKIP
)
7311 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
7312 /* Only encountered when an unresolved symbol occurs in a
7313 context other than a function call, in which case, it is
7315 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7316 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
7317 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7321 (to_static_fixed_type
7322 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
7328 unwrap_value (evaluate_subexp_standard
7329 (expect_type
, exp
, pos
, noside
));
7330 return ada_to_fixed_value (arg1
);
7336 /* Allocate arg vector, including space for the function to be
7337 called in argvec[0] and a terminating NULL. */
7338 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7340 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
7342 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
7343 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
7344 error (_("Unexpected unresolved symbol, %s, during evaluation"),
7345 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
7348 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7349 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7352 if (noside
== EVAL_SKIP
)
7356 if (ada_is_packed_array_type (desc_base_type (value_type (argvec
[0]))))
7357 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7358 else if (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_REF
7359 || (TYPE_CODE (value_type (argvec
[0])) == TYPE_CODE_ARRAY
7360 && VALUE_LVAL (argvec
[0]) == lval_memory
))
7361 argvec
[0] = value_addr (argvec
[0]);
7363 type
= ada_check_typedef (value_type (argvec
[0]));
7364 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7366 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type
))))
7368 case TYPE_CODE_FUNC
:
7369 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7371 case TYPE_CODE_ARRAY
:
7373 case TYPE_CODE_STRUCT
:
7374 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7375 argvec
[0] = ada_value_ind (argvec
[0]);
7376 type
= ada_check_typedef (TYPE_TARGET_TYPE (type
));
7379 error (_("cannot subscript or call something of type `%s'"),
7380 ada_type_name (value_type (argvec
[0])));
7385 switch (TYPE_CODE (type
))
7387 case TYPE_CODE_FUNC
:
7388 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7389 return allocate_value (TYPE_TARGET_TYPE (type
));
7390 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7391 case TYPE_CODE_STRUCT
:
7395 arity
= ada_array_arity (type
);
7396 type
= ada_array_element_type (type
, nargs
);
7398 error (_("cannot subscript or call a record"));
7400 error (_("wrong number of subscripts; expecting %d"), arity
);
7401 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7402 return allocate_value (ada_aligned_type (type
));
7404 unwrap_value (ada_value_subscript
7405 (argvec
[0], nargs
, argvec
+ 1));
7407 case TYPE_CODE_ARRAY
:
7408 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7410 type
= ada_array_element_type (type
, nargs
);
7412 error (_("element type of array unknown"));
7414 return allocate_value (ada_aligned_type (type
));
7417 unwrap_value (ada_value_subscript
7418 (ada_coerce_to_simple_array (argvec
[0]),
7419 nargs
, argvec
+ 1));
7420 case TYPE_CODE_PTR
: /* Pointer to array */
7421 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7422 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7424 type
= ada_array_element_type (type
, nargs
);
7426 error (_("element type of array unknown"));
7428 return allocate_value (ada_aligned_type (type
));
7431 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7432 nargs
, argvec
+ 1));
7435 error (_("Attempt to index or call something other than an \
7436 array or function"));
7441 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7442 struct value
*low_bound_val
=
7443 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7444 struct value
*high_bound_val
=
7445 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7448 low_bound_val
= coerce_ref (low_bound_val
);
7449 high_bound_val
= coerce_ref (high_bound_val
);
7450 low_bound
= pos_atr (low_bound_val
);
7451 high_bound
= pos_atr (high_bound_val
);
7453 if (noside
== EVAL_SKIP
)
7456 /* If this is a reference to an aligner type, then remove all
7458 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7459 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array
))))
7460 TYPE_TARGET_TYPE (value_type (array
)) =
7461 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array
)));
7463 if (ada_is_packed_array_type (value_type (array
)))
7464 error (_("cannot slice a packed array"));
7466 /* If this is a reference to an array or an array lvalue,
7467 convert to a pointer. */
7468 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_REF
7469 || (TYPE_CODE (value_type (array
)) == TYPE_CODE_ARRAY
7470 && VALUE_LVAL (array
) == lval_memory
))
7471 array
= value_addr (array
);
7473 if (noside
== EVAL_AVOID_SIDE_EFFECTS
7474 && ada_is_array_descriptor_type (ada_check_typedef
7475 (value_type (array
))))
7476 return empty_array (ada_type_of_array (array
, 0), low_bound
);
7478 array
= ada_coerce_to_simple_array_ptr (array
);
7480 /* If we have more than one level of pointer indirection,
7481 dereference the value until we get only one level. */
7482 while (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
7483 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array
)))
7485 array
= value_ind (array
);
7487 /* Make sure we really do have an array type before going further,
7488 to avoid a SEGV when trying to get the index type or the target
7489 type later down the road if the debug info generated by
7490 the compiler is incorrect or incomplete. */
7491 if (!ada_is_simple_array_type (value_type (array
)))
7492 error (_("cannot take slice of non-array"));
7494 if (TYPE_CODE (value_type (array
)) == TYPE_CODE_PTR
)
7496 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
7497 return empty_array (TYPE_TARGET_TYPE (value_type (array
)),
7501 struct type
*arr_type0
=
7502 to_fixed_array_type (TYPE_TARGET_TYPE (value_type (array
)),
7504 return ada_value_slice_ptr (array
, arr_type0
,
7509 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7511 else if (high_bound
< low_bound
)
7512 return empty_array (value_type (array
), low_bound
);
7514 return ada_value_slice (array
, (int) low_bound
, (int) high_bound
);
7519 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7520 type
= exp
->elts
[pc
+ 1].type
;
7522 if (noside
== EVAL_SKIP
)
7525 switch (TYPE_CODE (type
))
7528 lim_warning (_("Membership test incompletely implemented; \
7529 always returns true"));
7530 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
7532 case TYPE_CODE_RANGE
:
7533 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
7534 arg3
= value_from_longest (builtin_type_int
,
7535 TYPE_HIGH_BOUND (type
));
7537 value_from_longest (builtin_type_int
,
7538 (value_less (arg1
, arg3
)
7539 || value_equal (arg1
, arg3
))
7540 && (value_less (arg2
, arg1
)
7541 || value_equal (arg2
, arg1
)));
7544 case BINOP_IN_BOUNDS
:
7546 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7547 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7549 if (noside
== EVAL_SKIP
)
7552 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7553 return value_zero (builtin_type_int
, not_lval
);
7555 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7557 if (tem
< 1 || tem
> ada_array_arity (value_type (arg2
)))
7558 error (_("invalid dimension number to 'range"));
7560 arg3
= ada_array_bound (arg2
, tem
, 1);
7561 arg2
= ada_array_bound (arg2
, tem
, 0);
7564 value_from_longest (builtin_type_int
,
7565 (value_less (arg1
, arg3
)
7566 || value_equal (arg1
, arg3
))
7567 && (value_less (arg2
, arg1
)
7568 || value_equal (arg2
, arg1
)));
7570 case TERNOP_IN_RANGE
:
7571 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7572 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7573 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7575 if (noside
== EVAL_SKIP
)
7579 value_from_longest (builtin_type_int
,
7580 (value_less (arg1
, arg3
)
7581 || value_equal (arg1
, arg3
))
7582 && (value_less (arg2
, arg1
)
7583 || value_equal (arg2
, arg1
)));
7589 struct type
*type_arg
;
7590 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
7592 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7594 type_arg
= exp
->elts
[pc
+ 2].type
;
7598 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7602 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
7603 error (_("Invalid operand to '%s"), ada_attribute_name (op
));
7604 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
7607 if (noside
== EVAL_SKIP
)
7610 if (type_arg
== NULL
)
7612 arg1
= ada_coerce_ref (arg1
);
7614 if (ada_is_packed_array_type (value_type (arg1
)))
7615 arg1
= ada_coerce_to_simple_array (arg1
);
7617 if (tem
< 1 || tem
> ada_array_arity (value_type (arg1
)))
7618 error (_("invalid dimension number to '%s"),
7619 ada_attribute_name (op
));
7621 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7623 type
= ada_index_type (value_type (arg1
), tem
);
7626 (_("attempt to take bound of something that is not an array"));
7627 return allocate_value (type
);
7632 default: /* Should never happen. */
7633 error (_("unexpected attribute encountered"));
7635 return ada_array_bound (arg1
, tem
, 0);
7637 return ada_array_bound (arg1
, tem
, 1);
7639 return ada_array_length (arg1
, tem
);
7642 else if (discrete_type_p (type_arg
))
7644 struct type
*range_type
;
7645 char *name
= ada_type_name (type_arg
);
7647 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
7649 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
7650 if (range_type
== NULL
)
7651 range_type
= type_arg
;
7655 error (_("unexpected attribute encountered"));
7657 return discrete_type_low_bound (range_type
);
7659 return discrete_type_high_bound (range_type
);
7661 error (_("the 'length attribute applies only to array types"));
7664 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
7665 error (_("unimplemented type attribute"));
7670 if (ada_is_packed_array_type (type_arg
))
7671 type_arg
= decode_packed_array_type (type_arg
);
7673 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
7674 error (_("invalid dimension number to '%s"),
7675 ada_attribute_name (op
));
7677 type
= ada_index_type (type_arg
, tem
);
7680 (_("attempt to take bound of something that is not an array"));
7681 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7682 return allocate_value (type
);
7687 error (_("unexpected attribute encountered"));
7689 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7690 return value_from_longest (type
, low
);
7692 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
7693 return value_from_longest (type
, high
);
7695 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
7696 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
7697 return value_from_longest (type
, high
- low
+ 1);
7703 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7704 if (noside
== EVAL_SKIP
)
7707 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7708 return value_zero (ada_tag_type (arg1
), not_lval
);
7710 return ada_value_tag (arg1
);
7714 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7715 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7716 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7717 if (noside
== EVAL_SKIP
)
7719 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7720 return value_zero (value_type (arg1
), not_lval
);
7722 return value_binop (arg1
, arg2
,
7723 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
7725 case OP_ATR_MODULUS
:
7727 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
7728 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7730 if (noside
== EVAL_SKIP
)
7733 if (!ada_is_modular_type (type_arg
))
7734 error (_("'modulus must be applied to modular type"));
7736 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
7737 ada_modulus (type_arg
));
7742 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7743 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7744 if (noside
== EVAL_SKIP
)
7746 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7747 return value_zero (builtin_type_int
, not_lval
);
7749 return value_pos_atr (arg1
);
7752 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7753 if (noside
== EVAL_SKIP
)
7755 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7756 return value_zero (builtin_type_int
, not_lval
);
7758 return value_from_longest (builtin_type_int
,
7760 * TYPE_LENGTH (value_type (arg1
)));
7763 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
7764 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7765 type
= exp
->elts
[pc
+ 2].type
;
7766 if (noside
== EVAL_SKIP
)
7768 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7769 return value_zero (type
, not_lval
);
7771 return value_val_atr (type
, arg1
);
7774 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7775 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7776 if (noside
== EVAL_SKIP
)
7778 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7779 return value_zero (value_type (arg1
), not_lval
);
7781 return value_binop (arg1
, arg2
, op
);
7784 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7785 if (noside
== EVAL_SKIP
)
7791 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7792 if (noside
== EVAL_SKIP
)
7794 if (value_less (arg1
, value_zero (value_type (arg1
), not_lval
)))
7795 return value_neg (arg1
);
7800 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7801 expect_type
= TYPE_TARGET_TYPE (ada_check_typedef (expect_type
));
7802 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7803 if (noside
== EVAL_SKIP
)
7805 type
= ada_check_typedef (value_type (arg1
));
7806 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7808 if (ada_is_array_descriptor_type (type
))
7809 /* GDB allows dereferencing GNAT array descriptors. */
7811 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7812 if (arrType
== NULL
)
7813 error (_("Attempt to dereference null array pointer."));
7814 return value_at_lazy (arrType
, 0);
7816 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7817 || TYPE_CODE (type
) == TYPE_CODE_REF
7818 /* In C you can dereference an array to get the 1st elt. */
7819 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7821 type
= to_static_fixed_type
7823 (ada_check_typedef (TYPE_TARGET_TYPE (type
))));
7825 return value_zero (type
, lval_memory
);
7827 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7828 /* GDB allows dereferencing an int. */
7829 return value_zero (builtin_type_int
, lval_memory
);
7831 error (_("Attempt to take contents of a non-pointer value."));
7833 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
7834 type
= ada_check_typedef (value_type (arg1
));
7836 if (ada_is_array_descriptor_type (type
))
7837 /* GDB allows dereferencing GNAT array descriptors. */
7838 return ada_coerce_to_simple_array (arg1
);
7840 return ada_value_ind (arg1
);
7842 case STRUCTOP_STRUCT
:
7843 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7844 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7845 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7846 if (noside
== EVAL_SKIP
)
7848 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7850 struct type
*type1
= value_type (arg1
);
7851 if (ada_is_tagged_type (type1
, 1))
7853 type
= ada_lookup_struct_elt_type (type1
,
7854 &exp
->elts
[pc
+ 2].string
,
7857 /* In this case, we assume that the field COULD exist
7858 in some extension of the type. Return an object of
7859 "type" void, which will match any formal
7860 (see ada_type_match). */
7861 return value_zero (builtin_type_void
, lval_memory
);
7865 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
7868 return value_zero (ada_aligned_type (type
), lval_memory
);
7872 ada_to_fixed_value (unwrap_value
7873 (ada_value_struct_elt
7874 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
7876 /* The value is not supposed to be used. This is here to make it
7877 easier to accommodate expressions that contain types. */
7879 if (noside
== EVAL_SKIP
)
7881 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7882 return allocate_value (builtin_type_void
);
7884 error (_("Attempt to use a type name as an expression"));
7888 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7894 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7895 type name that encodes the 'small and 'delta information.
7896 Otherwise, return NULL. */
7899 fixed_type_info (struct type
*type
)
7901 const char *name
= ada_type_name (type
);
7902 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7904 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7906 const char *tail
= strstr (name
, "___XF_");
7912 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7913 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7918 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7921 ada_is_fixed_point_type (struct type
*type
)
7923 return fixed_type_info (type
) != NULL
;
7926 /* Return non-zero iff TYPE represents a System.Address type. */
7929 ada_is_system_address_type (struct type
*type
)
7931 return (TYPE_NAME (type
)
7932 && strcmp (TYPE_NAME (type
), "system__address") == 0);
7935 /* Assuming that TYPE is the representation of an Ada fixed-point
7936 type, return its delta, or -1 if the type is malformed and the
7937 delta cannot be determined. */
7940 ada_delta (struct type
*type
)
7942 const char *encoding
= fixed_type_info (type
);
7945 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7948 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7951 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7952 factor ('SMALL value) associated with the type. */
7955 scaling_factor (struct type
*type
)
7957 const char *encoding
= fixed_type_info (type
);
7958 unsigned long num0
, den0
, num1
, den1
;
7961 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7966 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7968 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7972 /* Assuming that X is the representation of a value of fixed-point
7973 type TYPE, return its floating-point equivalent. */
7976 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7978 return (DOUBLEST
) x
*scaling_factor (type
);
7981 /* The representation of a fixed-point value of type TYPE
7982 corresponding to the value X. */
7985 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7987 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7991 /* VAX floating formats */
7993 /* Non-zero iff TYPE represents one of the special VAX floating-point
7997 ada_is_vax_floating_type (struct type
*type
)
8000 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
8003 && (TYPE_CODE (type
) == TYPE_CODE_INT
8004 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8005 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
8008 /* The type of special VAX floating-point type this is, assuming
8009 ada_is_vax_floating_point. */
8012 ada_vax_float_type_suffix (struct type
*type
)
8014 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
8017 /* A value representing the special debugging function that outputs
8018 VAX floating-point values of the type represented by TYPE. Assumes
8019 ada_is_vax_floating_type (TYPE). */
8022 ada_vax_float_print_function (struct type
*type
)
8024 switch (ada_vax_float_type_suffix (type
))
8027 return get_var_value ("DEBUG_STRING_F", 0);
8029 return get_var_value ("DEBUG_STRING_D", 0);
8031 return get_var_value ("DEBUG_STRING_G", 0);
8033 error (_("invalid VAX floating-point type"));
8040 /* Scan STR beginning at position K for a discriminant name, and
8041 return the value of that discriminant field of DVAL in *PX. If
8042 PNEW_K is not null, put the position of the character beyond the
8043 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
8044 not alter *PX and *PNEW_K if unsuccessful. */
8047 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
8050 static char *bound_buffer
= NULL
;
8051 static size_t bound_buffer_len
= 0;
8054 struct value
*bound_val
;
8056 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
8059 pend
= strstr (str
+ k
, "__");
8063 k
+= strlen (bound
);
8067 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
8068 bound
= bound_buffer
;
8069 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
8070 bound
[pend
- (str
+ k
)] = '\0';
8074 bound_val
= ada_search_struct_field (bound
, dval
, 0, value_type (dval
));
8075 if (bound_val
== NULL
)
8078 *px
= value_as_long (bound_val
);
8084 /* Value of variable named NAME in the current environment. If
8085 no such variable found, then if ERR_MSG is null, returns 0, and
8086 otherwise causes an error with message ERR_MSG. */
8088 static struct value
*
8089 get_var_value (char *name
, char *err_msg
)
8091 struct ada_symbol_info
*syms
;
8094 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
8099 if (err_msg
== NULL
)
8102 error (("%s"), err_msg
);
8105 return value_of_variable (syms
[0].sym
, syms
[0].block
);
8108 /* Value of integer variable named NAME in the current environment. If
8109 no such variable found, returns 0, and sets *FLAG to 0. If
8110 successful, sets *FLAG to 1. */
8113 get_int_var_value (char *name
, int *flag
)
8115 struct value
*var_val
= get_var_value (name
, 0);
8127 return value_as_long (var_val
);
8132 /* Return a range type whose base type is that of the range type named
8133 NAME in the current environment, and whose bounds are calculated
8134 from NAME according to the GNAT range encoding conventions.
8135 Extract discriminant values, if needed, from DVAL. If a new type
8136 must be created, allocate in OBJFILE's space. The bounds
8137 information, in general, is encoded in NAME, the base type given in
8138 the named range type. */
8140 static struct type
*
8141 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
8143 struct type
*raw_type
= ada_find_any_type (name
);
8144 struct type
*base_type
;
8147 if (raw_type
== NULL
)
8148 base_type
= builtin_type_int
;
8149 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
8150 base_type
= TYPE_TARGET_TYPE (raw_type
);
8152 base_type
= raw_type
;
8154 subtype_info
= strstr (name
, "___XD");
8155 if (subtype_info
== NULL
)
8159 static char *name_buf
= NULL
;
8160 static size_t name_len
= 0;
8161 int prefix_len
= subtype_info
- name
;
8167 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
8168 strncpy (name_buf
, name
, prefix_len
);
8169 name_buf
[prefix_len
] = '\0';
8172 bounds_str
= strchr (subtype_info
, '_');
8175 if (*subtype_info
== 'L')
8177 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
8178 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
8180 if (bounds_str
[n
] == '_')
8182 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
8189 strcpy (name_buf
+ prefix_len
, "___L");
8190 L
= get_int_var_value (name_buf
, &ok
);
8193 lim_warning (_("Unknown lower bound, using 1."));
8198 if (*subtype_info
== 'U')
8200 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
8201 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
8207 strcpy (name_buf
+ prefix_len
, "___U");
8208 U
= get_int_var_value (name_buf
, &ok
);
8211 lim_warning (_("Unknown upper bound, using %ld."), (long) L
);
8216 if (objfile
== NULL
)
8217 objfile
= TYPE_OBJFILE (base_type
);
8218 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
8219 TYPE_NAME (type
) = name
;
8224 /* True iff NAME is the name of a range type. */
8227 ada_is_range_type_name (const char *name
)
8229 return (name
!= NULL
&& strstr (name
, "___XD"));
8235 /* True iff TYPE is an Ada modular type. */
8238 ada_is_modular_type (struct type
*type
)
8240 struct type
*subranged_type
= base_type (type
);
8242 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
8243 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
8244 && TYPE_UNSIGNED (subranged_type
));
8247 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
8250 ada_modulus (struct type
* type
)
8252 return (ULONGEST
) TYPE_HIGH_BOUND (type
) + 1;
8256 /* Information about operators given special treatment in functions
8258 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
8260 #define ADA_OPERATORS \
8261 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
8262 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
8263 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
8264 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
8265 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
8266 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
8267 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
8268 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
8269 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
8270 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
8271 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
8272 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
8273 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
8274 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
8275 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
8276 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
8279 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
8281 switch (exp
->elts
[pc
- 1].opcode
)
8284 operator_length_standard (exp
, pc
, oplenp
, argsp
);
8287 #define OP_DEFN(op, len, args, binop) \
8288 case op: *oplenp = len; *argsp = args; break;
8295 ada_op_name (enum exp_opcode opcode
)
8300 return op_name_standard (opcode
);
8301 #define OP_DEFN(op, len, args, binop) case op: return #op;
8307 /* As for operator_length, but assumes PC is pointing at the first
8308 element of the operator, and gives meaningful results only for the
8309 Ada-specific operators. */
8312 ada_forward_operator_length (struct expression
*exp
, int pc
,
8313 int *oplenp
, int *argsp
)
8315 switch (exp
->elts
[pc
].opcode
)
8318 *oplenp
= *argsp
= 0;
8320 #define OP_DEFN(op, len, args, binop) \
8321 case op: *oplenp = len; *argsp = args; break;
8328 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
8330 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
8335 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
8339 /* Ada attributes ('Foo). */
8346 case OP_ATR_MODULUS
:
8355 /* XXX: gdb_sprint_host_address, type_sprint */
8356 fprintf_filtered (stream
, _("Type @"));
8357 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
8358 fprintf_filtered (stream
, " (");
8359 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
8360 fprintf_filtered (stream
, ")");
8362 case BINOP_IN_BOUNDS
:
8363 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
8365 case TERNOP_IN_RANGE
:
8369 return dump_subexp_body_standard (exp
, stream
, elt
);
8373 for (i
= 0; i
< nargs
; i
+= 1)
8374 elt
= dump_subexp (exp
, stream
, elt
);
8379 /* The Ada extension of print_subexp (q.v.). */
8382 ada_print_subexp (struct expression
*exp
, int *pos
,
8383 struct ui_file
*stream
, enum precedence prec
)
8387 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
8389 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
8394 print_subexp_standard (exp
, pos
, stream
, prec
);
8399 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
8402 case BINOP_IN_BOUNDS
:
8403 /* XXX: sprint_subexp */
8405 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8406 fputs_filtered (" in ", stream
);
8407 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8408 fputs_filtered ("'range", stream
);
8409 if (exp
->elts
[pc
+ 1].longconst
> 1)
8410 fprintf_filtered (stream
, "(%ld)",
8411 (long) exp
->elts
[pc
+ 1].longconst
);
8414 case TERNOP_IN_RANGE
:
8416 if (prec
>= PREC_EQUAL
)
8417 fputs_filtered ("(", stream
);
8418 /* XXX: sprint_subexp */
8419 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8420 fputs_filtered (" in ", stream
);
8421 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8422 fputs_filtered (" .. ", stream
);
8423 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
8424 if (prec
>= PREC_EQUAL
)
8425 fputs_filtered (")", stream
);
8434 case OP_ATR_MODULUS
:
8440 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
8442 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
8443 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
8447 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8448 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
8452 for (tem
= 1; tem
< nargs
; tem
+= 1)
8454 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
8455 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
8457 fputs_filtered (")", stream
);
8463 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
8464 fputs_filtered ("'(", stream
);
8465 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
8466 fputs_filtered (")", stream
);
8471 /* XXX: sprint_subexp */
8472 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
8473 fputs_filtered (" in ", stream
);
8474 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
8479 /* Table mapping opcodes into strings for printing operators
8480 and precedences of the operators. */
8482 static const struct op_print ada_op_print_tab
[] = {
8483 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
8484 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
8485 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
8486 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
8487 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
8488 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
8489 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
8490 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
8491 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
8492 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
8493 {">", BINOP_GTR
, PREC_ORDER
, 0},
8494 {"<", BINOP_LESS
, PREC_ORDER
, 0},
8495 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
8496 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
8497 {"+", BINOP_ADD
, PREC_ADD
, 0},
8498 {"-", BINOP_SUB
, PREC_ADD
, 0},
8499 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
8500 {"*", BINOP_MUL
, PREC_MUL
, 0},
8501 {"/", BINOP_DIV
, PREC_MUL
, 0},
8502 {"rem", BINOP_REM
, PREC_MUL
, 0},
8503 {"mod", BINOP_MOD
, PREC_MUL
, 0},
8504 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
8505 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
8506 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
8507 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
8508 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
8509 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
8510 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
8511 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
8512 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
8513 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
8517 /* Fundamental Ada Types */
8519 /* Create a fundamental Ada type using default reasonable for the current
8522 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8523 define fundamental types such as "int" or "double". Others (stabs or
8524 DWARF version 2, etc) do define fundamental types. For the formats which
8525 don't provide fundamental types, gdb can create such types using this
8528 FIXME: Some compilers distinguish explicitly signed integral types
8529 (signed short, signed int, signed long) from "regular" integral types
8530 (short, int, long) in the debugging information. There is some dis-
8531 agreement as to how useful this feature is. In particular, gcc does
8532 not support this. Also, only some debugging formats allow the
8533 distinction to be passed on to a debugger. For now, we always just
8534 use "short", "int", or "long" as the type name, for both the implicit
8535 and explicitly signed types. This also makes life easier for the
8536 gdb test suite since we don't have to account for the differences
8537 in output depending upon what the compiler and debugging format
8538 support. We will probably have to re-examine the issue when gdb
8539 starts taking it's fundamental type information directly from the
8540 debugging information supplied by the compiler. fnf@cygnus.com */
8542 static struct type
*
8543 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8545 struct type
*type
= NULL
;
8550 /* FIXME: For now, if we are asked to produce a type not in this
8551 language, create the equivalent of a C integer type with the
8552 name "<?type?>". When all the dust settles from the type
8553 reconstruction work, this should probably become an error. */
8554 type
= init_type (TYPE_CODE_INT
,
8555 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8556 0, "<?type?>", objfile
);
8557 warning (_("internal error: no Ada fundamental type %d"), typeid);
8560 type
= init_type (TYPE_CODE_VOID
,
8561 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8562 0, "void", objfile
);
8565 type
= init_type (TYPE_CODE_INT
,
8566 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8567 0, "character", objfile
);
8569 case FT_SIGNED_CHAR
:
8570 type
= init_type (TYPE_CODE_INT
,
8571 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8572 0, "signed char", objfile
);
8574 case FT_UNSIGNED_CHAR
:
8575 type
= init_type (TYPE_CODE_INT
,
8576 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8577 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8580 type
= init_type (TYPE_CODE_INT
,
8581 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8582 0, "short_integer", objfile
);
8584 case FT_SIGNED_SHORT
:
8585 type
= init_type (TYPE_CODE_INT
,
8586 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8587 0, "short_integer", objfile
);
8589 case FT_UNSIGNED_SHORT
:
8590 type
= init_type (TYPE_CODE_INT
,
8591 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8592 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8595 type
= init_type (TYPE_CODE_INT
,
8596 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8597 0, "integer", objfile
);
8599 case FT_SIGNED_INTEGER
:
8600 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/
8602 0, "integer", objfile
); /* FIXME -fnf */
8604 case FT_UNSIGNED_INTEGER
:
8605 type
= init_type (TYPE_CODE_INT
,
8606 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8607 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8610 type
= init_type (TYPE_CODE_INT
,
8611 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8612 0, "long_integer", objfile
);
8614 case FT_SIGNED_LONG
:
8615 type
= init_type (TYPE_CODE_INT
,
8616 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8617 0, "long_integer", objfile
);
8619 case FT_UNSIGNED_LONG
:
8620 type
= init_type (TYPE_CODE_INT
,
8621 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8622 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8625 type
= init_type (TYPE_CODE_INT
,
8626 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8627 0, "long_long_integer", objfile
);
8629 case FT_SIGNED_LONG_LONG
:
8630 type
= init_type (TYPE_CODE_INT
,
8631 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8632 0, "long_long_integer", objfile
);
8634 case FT_UNSIGNED_LONG_LONG
:
8635 type
= init_type (TYPE_CODE_INT
,
8636 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8637 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8640 type
= init_type (TYPE_CODE_FLT
,
8641 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8642 0, "float", objfile
);
8644 case FT_DBL_PREC_FLOAT
:
8645 type
= init_type (TYPE_CODE_FLT
,
8646 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8647 0, "long_float", objfile
);
8649 case FT_EXT_PREC_FLOAT
:
8650 type
= init_type (TYPE_CODE_FLT
,
8651 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8652 0, "long_long_float", objfile
);
8658 enum ada_primitive_types
{
8659 ada_primitive_type_int
,
8660 ada_primitive_type_long
,
8661 ada_primitive_type_short
,
8662 ada_primitive_type_char
,
8663 ada_primitive_type_float
,
8664 ada_primitive_type_double
,
8665 ada_primitive_type_void
,
8666 ada_primitive_type_long_long
,
8667 ada_primitive_type_long_double
,
8668 ada_primitive_type_natural
,
8669 ada_primitive_type_positive
,
8670 ada_primitive_type_system_address
,
8671 nr_ada_primitive_types
8675 ada_language_arch_info (struct gdbarch
*current_gdbarch
,
8676 struct language_arch_info
*lai
)
8678 const struct builtin_type
*builtin
= builtin_type (current_gdbarch
);
8679 lai
->primitive_type_vector
8680 = GDBARCH_OBSTACK_CALLOC (current_gdbarch
, nr_ada_primitive_types
+ 1,
8682 lai
->primitive_type_vector
[ada_primitive_type_int
] =
8683 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8684 0, "integer", (struct objfile
*) NULL
);
8685 lai
->primitive_type_vector
[ada_primitive_type_long
] =
8686 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8687 0, "long_integer", (struct objfile
*) NULL
);
8688 lai
->primitive_type_vector
[ada_primitive_type_short
] =
8689 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8690 0, "short_integer", (struct objfile
*) NULL
);
8691 lai
->string_char_type
=
8692 lai
->primitive_type_vector
[ada_primitive_type_char
] =
8693 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8694 0, "character", (struct objfile
*) NULL
);
8695 lai
->primitive_type_vector
[ada_primitive_type_float
] =
8696 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8697 0, "float", (struct objfile
*) NULL
);
8698 lai
->primitive_type_vector
[ada_primitive_type_double
] =
8699 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8700 0, "long_float", (struct objfile
*) NULL
);
8701 lai
->primitive_type_vector
[ada_primitive_type_long_long
] =
8702 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8703 0, "long_long_integer", (struct objfile
*) NULL
);
8704 lai
->primitive_type_vector
[ada_primitive_type_long_double
] =
8705 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8706 0, "long_long_float", (struct objfile
*) NULL
);
8707 lai
->primitive_type_vector
[ada_primitive_type_natural
] =
8708 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8709 0, "natural", (struct objfile
*) NULL
);
8710 lai
->primitive_type_vector
[ada_primitive_type_positive
] =
8711 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8712 0, "positive", (struct objfile
*) NULL
);
8713 lai
->primitive_type_vector
[ada_primitive_type_void
] = builtin
->builtin_void
;
8715 lai
->primitive_type_vector
[ada_primitive_type_system_address
] =
8716 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8717 (struct objfile
*) NULL
));
8718 TYPE_NAME (lai
->primitive_type_vector
[ada_primitive_type_system_address
])
8719 = "system__address";
8722 /* Language vector */
8724 /* Not really used, but needed in the ada_language_defn. */
8727 emit_char (int c
, struct ui_file
*stream
, int quoter
)
8729 ada_emit_char (c
, stream
, quoter
, 1);
8735 warnings_issued
= 0;
8736 return ada_parse ();
8739 static const struct exp_descriptor ada_exp_descriptor
= {
8741 ada_operator_length
,
8743 ada_dump_subexp_body
,
8747 const struct language_defn ada_language_defn
= {
8748 "ada", /* Language name */
8753 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8754 that's not quite what this means. */
8756 &ada_exp_descriptor
,
8760 ada_printchar
, /* Print a character constant */
8761 ada_printstr
, /* Function to print string constant */
8762 emit_char
, /* Function to print single char (not used) */
8763 ada_create_fundamental_type
, /* Create fundamental type in this language */
8764 ada_print_type
, /* Print a type using appropriate syntax */
8765 ada_val_print
, /* Print a value using appropriate syntax */
8766 ada_value_print
, /* Print a top-level value */
8767 NULL
, /* Language specific skip_trampoline */
8768 NULL
, /* value_of_this */
8769 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
8770 basic_lookup_transparent_type
, /* lookup_transparent_type */
8771 ada_la_decode
, /* Language specific symbol demangler */
8772 NULL
, /* Language specific class_name_from_physname */
8773 ada_op_print_tab
, /* expression operators for printing */
8774 0, /* c-style arrays */
8775 1, /* String lower bound */
8777 ada_get_gdb_completer_word_break_characters
,
8778 ada_language_arch_info
,
8779 ada_print_array_index
,
8784 _initialize_ada_language (void)
8786 add_language (&ada_language_defn
);
8788 varsize_limit
= 65536;
8790 obstack_init (&symbol_list_obstack
);
8792 decoded_names_store
= htab_create_alloc
8793 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
8794 NULL
, xcalloc
, xfree
);