GDB (xrefs)

/tmp/gdb-8.1/gdb/ada-lang.c
Go to the documentation of this file.
1 /* Ada language support routines for GDB, the GNU debugger.
2
3 Copyright (C) 1992-2018 Free Software Foundation, Inc.
4
5 This file is part of GDB.
6
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
19
20
21 #include "defs.h"
22 #include <ctype.h>
23 #include "demangle.h"
24 #include "gdb_regex.h"
25 #include "frame.h"
26 #include "symtab.h"
27 #include "gdbtypes.h"
28 #include "gdbcmd.h"
29 #include "expression.h"
30 #include "parser-defs.h"
31 #include "language.h"
32 #include "varobj.h"
33 #include "c-lang.h"
34 #include "inferior.h"
35 #include "symfile.h"
36 #include "objfiles.h"
37 #include "breakpoint.h"
38 #include "gdbcore.h"
39 #include "hashtab.h"
40 #include "gdb_obstack.h"
41 #include "ada-lang.h"
42 #include "completer.h"
43 #include <sys/stat.h>
44 #include "ui-out.h"
45 #include "block.h"
46 #include "infcall.h"
47 #include "dictionary.h"
48 #include "annotate.h"
49 #include "valprint.h"
50 #include "source.h"
51 #include "observer.h"
52 #include "vec.h"
53 #include "stack.h"
54 #include "gdb_vecs.h"
55 #include "typeprint.h"
56 #include "namespace.h"
57
58 #include "psymtab.h"
59 #include "value.h"
60 #include "mi/mi-common.h"
61 #include "arch-utils.h"
62 #include "cli/cli-utils.h"
63 #include "common/function-view.h"
64 #include "common/byte-vector.h"
65 #include <algorithm>
66
67 /* Define whether or not the C operator '/' truncates towards zero for
68 differently signed operands (truncation direction is undefined in C).
69 Copied from valarith.c. */
70
71 #ifndef TRUNCATION_TOWARDS_ZERO
72 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
73 #endif
74
75 static struct type *desc_base_type (struct type *);
76
77 static struct type *desc_bounds_type (struct type *);
78
79 static struct value *desc_bounds (struct value *);
80
81 static int fat_pntr_bounds_bitpos (struct type *);
82
83 static int fat_pntr_bounds_bitsize (struct type *);
84
85 static struct type *desc_data_target_type (struct type *);
86
87 static struct value *desc_data (struct value *);
88
89 static int fat_pntr_data_bitpos (struct type *);
90
91 static int fat_pntr_data_bitsize (struct type *);
92
93 static struct value *desc_one_bound (struct value *, int, int);
94
95 static int desc_bound_bitpos (struct type *, int, int);
96
97 static int desc_bound_bitsize (struct type *, int, int);
98
99 static struct type *desc_index_type (struct type *, int);
100
101 static int desc_arity (struct type *);
102
103 static int ada_type_match (struct type *, struct type *, int);
104
105 static int ada_args_match (struct symbol *, struct value **, int);
106
107 static struct value *make_array_descriptor (struct type *, struct value *);
108
109 static void ada_add_block_symbols (struct obstack *,
110 const struct block *,
111 const lookup_name_info &lookup_name,
112 domain_enum, struct objfile *);
113
114 static void ada_add_all_symbols (struct obstack *, const struct block *,
115 const lookup_name_info &lookup_name,
116 domain_enum, int, int *);
117
118 static int is_nonfunction (struct block_symbol *, int);
119
120 static void add_defn_to_vec (struct obstack *, struct symbol *,
121 const struct block *);
122
123 static int num_defns_collected (struct obstack *);
124
125 static struct block_symbol *defns_collected (struct obstack *, int);
126
127 static struct value *resolve_subexp (expression_up *, int *, int,
128 struct type *);
129
130 static void replace_operator_with_call (expression_up *, int, int, int,
131 struct symbol *, const struct block *);
132
133 static int possible_user_operator_p (enum exp_opcode, struct value **);
134
135 static const char *ada_op_name (enum exp_opcode);
136
137 static const char *ada_decoded_op_name (enum exp_opcode);
138
139 static int numeric_type_p (struct type *);
140
141 static int integer_type_p (struct type *);
142
143 static int scalar_type_p (struct type *);
144
145 static int discrete_type_p (struct type *);
146
147 static enum ada_renaming_category parse_old_style_renaming (struct type *,
148 const char **,
149 int *,
150 const char **);
151
152 static struct symbol *find_old_style_renaming_symbol (const char *,
153 const struct block *);
154
155 static struct type *ada_lookup_struct_elt_type (struct type *, const char *,
156 int, int);
157
158 static struct value *evaluate_subexp_type (struct expression *, int *);
159
160 static struct type *ada_find_parallel_type_with_name (struct type *,
161 const char *);
162
163 static int is_dynamic_field (struct type *, int);
164
165 static struct type *to_fixed_variant_branch_type (struct type *,
166 const gdb_byte *,
167 CORE_ADDR, struct value *);
168
169 static struct type *to_fixed_array_type (struct type *, struct value *, int);
170
171 static struct type *to_fixed_range_type (struct type *, struct value *);
172
173 static struct type *to_static_fixed_type (struct type *);
174 static struct type *static_unwrap_type (struct type *type);
175
176 static struct value *unwrap_value (struct value *);
177
178 static struct type *constrained_packed_array_type (struct type *, long *);
179
180 static struct type *decode_constrained_packed_array_type (struct type *);
181
182 static long decode_packed_array_bitsize (struct type *);
183
184 static struct value *decode_constrained_packed_array (struct value *);
185
186 static int ada_is_packed_array_type (struct type *);
187
188 static int ada_is_unconstrained_packed_array_type (struct type *);
189
190 static struct value *value_subscript_packed (struct value *, int,
191 struct value **);
192
193 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
194
195 static struct value *coerce_unspec_val_to_type (struct value *,
196 struct type *);
197
198 static int lesseq_defined_than (struct symbol *, struct symbol *);
199
200 static int equiv_types (struct type *, struct type *);
201
202 static int is_name_suffix (const char *);
203
204 static int advance_wild_match (const char **, const char *, int);
205
206 static bool wild_match (const char *name, const char *patn);
207
208 static struct value *ada_coerce_ref (struct value *);
209
210 static LONGEST pos_atr (struct value *);
211
212 static struct value *value_pos_atr (struct type *, struct value *);
213
214 static struct value *value_val_atr (struct type *, struct value *);
215
216 static struct symbol *standard_lookup (const char *, const struct block *,
217 domain_enum);
218
219 static struct value *ada_search_struct_field (const char *, struct value *, int,
220 struct type *);
221
222 static struct value *ada_value_primitive_field (struct value *, int, int,
223 struct type *);
224
225 static int find_struct_field (const char *, struct type *, int,
226 struct type **, int *, int *, int *, int *);
227
228 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
229 struct value *);
230
231 static int ada_resolve_function (struct block_symbol *, int,
232 struct value **, int, const char *,
233 struct type *);
234
235 static int ada_is_direct_array_type (struct type *);
236
237 static void ada_language_arch_info (struct gdbarch *,
238 struct language_arch_info *);
239
240 static struct value *ada_index_struct_field (int, struct value *, int,
241 struct type *);
242
243 static struct value *assign_aggregate (struct value *, struct value *,
244 struct expression *,
245 int *, enum noside);
246
247 static void aggregate_assign_from_choices (struct value *, struct value *,
248 struct expression *,
249 int *, LONGEST *, int *,
250 int, LONGEST, LONGEST);
251
252 static void aggregate_assign_positional (struct value *, struct value *,
253 struct expression *,
254 int *, LONGEST *, int *, int,
255 LONGEST, LONGEST);
256
257
258 static void aggregate_assign_others (struct value *, struct value *,
259 struct expression *,
260 int *, LONGEST *, int, LONGEST, LONGEST);
261
262
263 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
264
265
266 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
267 int *, enum noside);
268
269 static void ada_forward_operator_length (struct expression *, int, int *,
270 int *);
271
272 static struct type *ada_find_any_type (const char *name);
273
274 static symbol_name_matcher_ftype *ada_get_symbol_name_matcher
275 (const lookup_name_info &lookup_name);
276
277
278
279 /* The result of a symbol lookup to be stored in our symbol cache. */
280
281 struct cache_entry
282 {
283 /* The name used to perform the lookup. */
284 const char *name;
285 /* The namespace used during the lookup. */
286 domain_enum domain;
287 /* The symbol returned by the lookup, or NULL if no matching symbol
288 was found. */
289 struct symbol *sym;
290 /* The block where the symbol was found, or NULL if no matching
291 symbol was found. */
292 const struct block *block;
293 /* A pointer to the next entry with the same hash. */
294 struct cache_entry *next;
295 };
296
297 /* The Ada symbol cache, used to store the result of Ada-mode symbol
298 lookups in the course of executing the user's commands.
299
300 The cache is implemented using a simple, fixed-sized hash.
301 The size is fixed on the grounds that there are not likely to be
302 all that many symbols looked up during any given session, regardless
303 of the size of the symbol table. If we decide to go to a resizable
304 table, let's just use the stuff from libiberty instead. */
305
306 #define HASH_SIZE 1009
307
308 struct ada_symbol_cache
309 {
310 /* An obstack used to store the entries in our cache. */
311 struct obstack cache_space;
312
313 /* The root of the hash table used to implement our symbol cache. */
314 struct cache_entry *root[HASH_SIZE];
315 };
316
317 static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
318
319 /* Maximum-sized dynamic type. */
320 static unsigned int varsize_limit;
321
322 static const char ada_completer_word_break_characters[] =
323 #ifdef VMS
324 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
325 #else
326 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
327 #endif
328
329 /* The name of the symbol to use to get the name of the main subprogram. */
330 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
331 = "__gnat_ada_main_program_name";
332
333 /* Limit on the number of warnings to raise per expression evaluation. */
334 static int warning_limit = 2;
335
336 /* Number of warning messages issued; reset to 0 by cleanups after
337 expression evaluation. */
338 static int warnings_issued = 0;
339
340 static const char *known_runtime_file_name_patterns[] = {
341 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
342 };
343
344 static const char *known_auxiliary_function_name_patterns[] = {
345 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
346 };
347
348 /* Maintenance-related settings for this module. */
349
350 static struct cmd_list_element *maint_set_ada_cmdlist;
351 static struct cmd_list_element *maint_show_ada_cmdlist;
352
353 /* Implement the "maintenance set ada" (prefix) command. */
354
355 static void
356 maint_set_ada_cmd (const char *args, int from_tty)
357 {
358 help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
359 gdb_stdout);
360 }
361
362 /* Implement the "maintenance show ada" (prefix) command. */
363
364 static void
365 maint_show_ada_cmd (const char *args, int from_tty)
366 {
367 cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
368 }
369
370 /* The "maintenance ada set/show ignore-descriptive-type" value. */
371
372 static int ada_ignore_descriptive_types_p = 0;
373
374 /* Inferior-specific data. */
375
376 /* Per-inferior data for this module. */
377
378 struct ada_inferior_data
379 {
380 /* The ada__tags__type_specific_data type, which is used when decoding
381 tagged types. With older versions of GNAT, this type was directly
382 accessible through a component ("tsd") in the object tag. But this
383 is no longer the case, so we cache it for each inferior. */
384 struct type *tsd_type;
385
386 /* The exception_support_info data. This data is used to determine
387 how to implement support for Ada exception catchpoints in a given
388 inferior. */
389 const struct exception_support_info *exception_info;
390 };
391
392 /* Our key to this module's inferior data. */
393 static const struct inferior_data *ada_inferior_data;
394
395 /* A cleanup routine for our inferior data. */
396 static void
397 ada_inferior_data_cleanup (struct inferior *inf, void *arg)
398 {
399 struct ada_inferior_data *data;
400
401 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
402 if (data != NULL)
403 xfree (data);
404 }
405
406 /* Return our inferior data for the given inferior (INF).
407
408 This function always returns a valid pointer to an allocated
409 ada_inferior_data structure. If INF's inferior data has not
410 been previously set, this functions creates a new one with all
411 fields set to zero, sets INF's inferior to it, and then returns
412 a pointer to that newly allocated ada_inferior_data. */
413
414 static struct ada_inferior_data *
415 get_ada_inferior_data (struct inferior *inf)
416 {
417 struct ada_inferior_data *data;
418
419 data = (struct ada_inferior_data *) inferior_data (inf, ada_inferior_data);
420 if (data == NULL)
421 {
422 data = XCNEW (struct ada_inferior_data);
423 set_inferior_data (inf, ada_inferior_data, data);
424 }
425
426 return data;
427 }
428
429 /* Perform all necessary cleanups regarding our module's inferior data
430 that is required after the inferior INF just exited. */
431
432 static void
433 ada_inferior_exit (struct inferior *inf)
434 {
435 ada_inferior_data_cleanup (inf, NULL);
436 set_inferior_data (inf, ada_inferior_data, NULL);
437 }
438
439
440 /* program-space-specific data. */
441
442 /* This module's per-program-space data. */
443 struct ada_pspace_data
444 {
445 /* The Ada symbol cache. */
446 struct ada_symbol_cache *sym_cache;
447 };
448
449 /* Key to our per-program-space data. */
450 static const struct program_space_data *ada_pspace_data_handle;
451
452 /* Return this module's data for the given program space (PSPACE).
453 If not is found, add a zero'ed one now.
454
455 This function always returns a valid object. */
456
457 static struct ada_pspace_data *
458 get_ada_pspace_data (struct program_space *pspace)
459 {
460 struct ada_pspace_data *data;
461
462 data = ((struct ada_pspace_data *)
463 program_space_data (pspace, ada_pspace_data_handle));
464 if (data == NULL)
465 {
466 data = XCNEW (struct ada_pspace_data);
467 set_program_space_data (pspace, ada_pspace_data_handle, data);
468 }
469
470 return data;
471 }
472
473 /* The cleanup callback for this module's per-program-space data. */
474
475 static void
476 ada_pspace_data_cleanup (struct program_space *pspace, void *data)
477 {
478 struct ada_pspace_data *pspace_data = (struct ada_pspace_data *) data;
479
480 if (pspace_data->sym_cache != NULL)
481 ada_free_symbol_cache (pspace_data->sym_cache);
482 xfree (pspace_data);
483 }
484
485 /* Utilities */
486
487 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
488 all typedef layers have been peeled. Otherwise, return TYPE.
489
490 Normally, we really expect a typedef type to only have 1 typedef layer.
491 In other words, we really expect the target type of a typedef type to be
492 a non-typedef type. This is particularly true for Ada units, because
493 the language does not have a typedef vs not-typedef distinction.
494 In that respect, the Ada compiler has been trying to eliminate as many
495 typedef definitions in the debugging information, since they generally
496 do not bring any extra information (we still use typedef under certain
497 circumstances related mostly to the GNAT encoding).
498
499 Unfortunately, we have seen situations where the debugging information
500 generated by the compiler leads to such multiple typedef layers. For
501 instance, consider the following example with stabs:
502
503 .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
504 .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
505
506 This is an error in the debugging information which causes type
507 pck__float_array___XUP to be defined twice, and the second time,
508 it is defined as a typedef of a typedef.
509
510 This is on the fringe of legality as far as debugging information is
511 concerned, and certainly unexpected. But it is easy to handle these
512 situations correctly, so we can afford to be lenient in this case. */
513
514 static struct type *
515 ada_typedef_target_type (struct type *type)
516 {
517 while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
518 type = TYPE_TARGET_TYPE (type);
519 return type;
520 }
521
522 /* Given DECODED_NAME a string holding a symbol name in its
523 decoded form (ie using the Ada dotted notation), returns
524 its unqualified name. */
525
526 static const char *
527 ada_unqualified_name (const char *decoded_name)
528 {
529 const char *result;
530
531 /* If the decoded name starts with '<', it means that the encoded
532 name does not follow standard naming conventions, and thus that
533 it is not your typical Ada symbol name. Trying to unqualify it
534 is therefore pointless and possibly erroneous. */
535 if (decoded_name[0] == '<')
536 return decoded_name;
537
538 result = strrchr (decoded_name, '.');
539 if (result != NULL)
540 result++; /* Skip the dot... */
541 else
542 result = decoded_name;
543
544 return result;
545 }
546
547 /* Return a string starting with '<', followed by STR, and '>'.
548 The result is good until the next call. */
549
550 static char *
551 add_angle_brackets (const char *str)
552 {
553 static char *result = NULL;
554
555 xfree (result);
556 result = xstrprintf ("<%s>", str);
557 return result;
558 }
559
560 static const char *
561 ada_get_gdb_completer_word_break_characters (void)
562 {
563 return ada_completer_word_break_characters;
564 }
565
566 /* Print an array element index using the Ada syntax. */
567
568 static void
569 ada_print_array_index (struct value *index_value, struct ui_file *stream,
570 const struct value_print_options *options)
571 {
572 LA_VALUE_PRINT (index_value, stream, options);
573 fprintf_filtered (stream, " => ");
574 }
575
576 /* Assuming VECT points to an array of *SIZE objects of size
577 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
578 updating *SIZE as necessary and returning the (new) array. */
579
580 void *
581 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
582 {
583 if (*size < min_size)
584 {
585 *size *= 2;
586 if (*size < min_size)
587 *size = min_size;
588 vect = xrealloc (vect, *size * element_size);
589 }
590 return vect;
591 }
592
593 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
594 suffix of FIELD_NAME beginning "___". */
595
596 static int
597 field_name_match (const char *field_name, const char *target)
598 {
599 int len = strlen (target);
600
601 return
602 (strncmp (field_name, target, len) == 0
603 && (field_name[len] == '\0'
604 || (startswith (field_name + len, "___")
605 && strcmp (field_name + strlen (field_name) - 6,
606 "___XVN") != 0)));
607 }
608
609
610 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
611 a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
612 and return its index. This function also handles fields whose name
613 have ___ suffixes because the compiler sometimes alters their name
614 by adding such a suffix to represent fields with certain constraints.
615 If the field could not be found, return a negative number if
616 MAYBE_MISSING is set. Otherwise raise an error. */
617
618 int
619 ada_get_field_index (const struct type *type, const char *field_name,
620 int maybe_missing)
621 {
622 int fieldno;
623 struct type *struct_type = check_typedef ((struct type *) type);
624
625 for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
626 if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
627 return fieldno;
628
629 if (!maybe_missing)
630 error (_("Unable to find field %s in struct %s. Aborting"),
631 field_name, TYPE_NAME (struct_type));
632
633 return -1;
634 }
635
636 /* The length of the prefix of NAME prior to any "___" suffix. */
637
638 int
639 ada_name_prefix_len (const char *name)
640 {
641 if (name == NULL)
642 return 0;
643 else
644 {
645 const char *p = strstr (name, "___");
646
647 if (p == NULL)
648 return strlen (name);
649 else
650 return p - name;
651 }
652 }
653
654 /* Return non-zero if SUFFIX is a suffix of STR.
655 Return zero if STR is null. */
656
657 static int
658 is_suffix (const char *str, const char *suffix)
659 {
660 int len1, len2;
661
662 if (str == NULL)
663 return 0;
664 len1 = strlen (str);
665 len2 = strlen (suffix);
666 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
667 }
668
669 /* The contents of value VAL, treated as a value of type TYPE. The
670 result is an lval in memory if VAL is. */
671
672 static struct value *
673 coerce_unspec_val_to_type (struct value *val, struct type *type)
674 {
675 type = ada_check_typedef (type);
676 if (value_type (val) == type)
677 return val;
678 else
679 {
680 struct value *result;
681
682 /* Make sure that the object size is not unreasonable before
683 trying to allocate some memory for it. */
684 ada_ensure_varsize_limit (type);
685
686 if (value_lazy (val)
687 || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
688 result = allocate_value_lazy (type);
689 else
690 {
691 result = allocate_value (type);
692 value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
693 }
694 set_value_component_location (result, val);
695 set_value_bitsize (result, value_bitsize (val));
696 set_value_bitpos (result, value_bitpos (val));
697 set_value_address (result, value_address (val));
698 return result;
699 }
700 }
701
702 static const gdb_byte *
703 cond_offset_host (const gdb_byte *valaddr, long offset)
704 {
705 if (valaddr == NULL)
706 return NULL;
707 else
708 return valaddr + offset;
709 }
710
711 static CORE_ADDR
712 cond_offset_target (CORE_ADDR address, long offset)
713 {
714 if (address == 0)
715 return 0;
716 else
717 return address + offset;
718 }
719
720 /* Issue a warning (as for the definition of warning in utils.c, but
721 with exactly one argument rather than ...), unless the limit on the
722 number of warnings has passed during the evaluation of the current
723 expression. */
724
725 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
726 provided by "complaint". */
727 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
728
729 static void
730 lim_warning (const char *format, ...)
731 {
732 va_list args;
733
734 va_start (args, format);
735 warnings_issued += 1;
736 if (warnings_issued <= warning_limit)
737 vwarning (format, args);
738
739 va_end (args);
740 }
741
742 /* Issue an error if the size of an object of type T is unreasonable,
743 i.e. if it would be a bad idea to allocate a value of this type in
744 GDB. */
745
746 void
747 ada_ensure_varsize_limit (const struct type *type)
748 {
749 if (TYPE_LENGTH (type) > varsize_limit)
750 error (_("object size is larger than varsize-limit"));
751 }
752
753 /* Maximum value of a SIZE-byte signed integer type. */
754 static LONGEST
755 max_of_size (int size)
756 {
757 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
758
759 return top_bit | (top_bit - 1);
760 }
761
762 /* Minimum value of a SIZE-byte signed integer type. */
763 static LONGEST
764 min_of_size (int size)
765 {
766 return -max_of_size (size) - 1;
767 }
768
769 /* Maximum value of a SIZE-byte unsigned integer type. */
770 static ULONGEST
771 umax_of_size (int size)
772 {
773 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
774
775 return top_bit | (top_bit - 1);
776 }
777
778 /* Maximum value of integral type T, as a signed quantity. */
779 static LONGEST
780 max_of_type (struct type *t)
781 {
782 if (TYPE_UNSIGNED (t))
783 return (LONGEST) umax_of_size (TYPE_LENGTH (t));
784 else
785 return max_of_size (TYPE_LENGTH (t));
786 }
787
788 /* Minimum value of integral type T, as a signed quantity. */
789 static LONGEST
790 min_of_type (struct type *t)
791 {
792 if (TYPE_UNSIGNED (t))
793 return 0;
794 else
795 return min_of_size (TYPE_LENGTH (t));
796 }
797
798 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
799 LONGEST
800 ada_discrete_type_high_bound (struct type *type)
801 {
802 type = resolve_dynamic_type (type, NULL, 0);
803 switch (TYPE_CODE (type))
804 {
805 case TYPE_CODE_RANGE:
806 return TYPE_HIGH_BOUND (type);
807 case TYPE_CODE_ENUM:
808 return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
809 case TYPE_CODE_BOOL:
810 return 1;
811 case TYPE_CODE_CHAR:
812 case TYPE_CODE_INT:
813 return max_of_type (type);
814 default:
815 error (_("Unexpected type in ada_discrete_type_high_bound."));
816 }
817 }
818
819 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
820 LONGEST
821 ada_discrete_type_low_bound (struct type *type)
822 {
823 type = resolve_dynamic_type (type, NULL, 0);
824 switch (TYPE_CODE (type))
825 {
826 case TYPE_CODE_RANGE:
827 return TYPE_LOW_BOUND (type);
828 case TYPE_CODE_ENUM:
829 return TYPE_FIELD_ENUMVAL (type, 0);
830 case TYPE_CODE_BOOL:
831 return 0;
832 case TYPE_CODE_CHAR:
833 case TYPE_CODE_INT:
834 return min_of_type (type);
835 default:
836 error (_("Unexpected type in ada_discrete_type_low_bound."));
837 }
838 }
839
840 /* The identity on non-range types. For range types, the underlying
841 non-range scalar type. */
842
843 static struct type *
844 get_base_type (struct type *type)
845 {
846 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
847 {
848 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
849 return type;
850 type = TYPE_TARGET_TYPE (type);
851 }
852 return type;
853 }
854
855 /* Return a decoded version of the given VALUE. This means returning
856 a value whose type is obtained by applying all the GNAT-specific
857 encondings, making the resulting type a static but standard description
858 of the initial type. */
859
860 struct value *
861 ada_get_decoded_value (struct value *value)
862 {
863 struct type *type = ada_check_typedef (value_type (value));
864
865 if (ada_is_array_descriptor_type (type)
866 || (ada_is_constrained_packed_array_type (type)
867 && TYPE_CODE (type) != TYPE_CODE_PTR))
868 {
869 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
870 value = ada_coerce_to_simple_array_ptr (value);
871 else
872 value = ada_coerce_to_simple_array (value);
873 }
874 else
875 value = ada_to_fixed_value (value);
876
877 return value;
878 }
879
880 /* Same as ada_get_decoded_value, but with the given TYPE.
881 Because there is no associated actual value for this type,
882 the resulting type might be a best-effort approximation in
883 the case of dynamic types. */
884
885 struct type *
886 ada_get_decoded_type (struct type *type)
887 {
888 type = to_static_fixed_type (type);
889 if (ada_is_constrained_packed_array_type (type))
890 type = ada_coerce_to_simple_array_type (type);
891 return type;
892 }
893
894
895
896 /* Language Selection */
897
898 /* If the main program is in Ada, return language_ada, otherwise return LANG
899 (the main program is in Ada iif the adainit symbol is found). */
900
901 enum language
902 ada_update_initial_language (enum language lang)
903 {
904 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
905 (struct objfile *) NULL).minsym != NULL)
906 return language_ada;
907
908 return lang;
909 }
910
911 /* If the main procedure is written in Ada, then return its name.
912 The result is good until the next call. Return NULL if the main
913 procedure doesn't appear to be in Ada. */
914
915 char *
916 ada_main_name (void)
917 {
918 struct bound_minimal_symbol msym;
919 static char *main_program_name = NULL;
920
921 /* For Ada, the name of the main procedure is stored in a specific
922 string constant, generated by the binder. Look for that symbol,
923 extract its address, and then read that string. If we didn't find
924 that string, then most probably the main procedure is not written
925 in Ada. */
926 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
927
928 if (msym.minsym != NULL)
929 {
930 CORE_ADDR main_program_name_addr;
931 int err_code;
932
933 main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
934 if (main_program_name_addr == 0)
935 error (_("Invalid address for Ada main program name."));
936
937 xfree (main_program_name);
938 target_read_string (main_program_name_addr, &main_program_name,
939 1024, &err_code);
940
941 if (err_code != 0)
942 return NULL;
943 return main_program_name;
944 }
945
946 /* The main procedure doesn't seem to be in Ada. */
947 return NULL;
948 }
949
950 /* Symbols */
951
952 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
953 of NULLs. */
954
955 const struct ada_opname_map ada_opname_table[] = {
956 {"Oadd", "\"+\"", BINOP_ADD},
957 {"Osubtract", "\"-\"", BINOP_SUB},
958 {"Omultiply", "\"*\"", BINOP_MUL},
959 {"Odivide", "\"/\"", BINOP_DIV},
960 {"Omod", "\"mod\"", BINOP_MOD},
961 {"Orem", "\"rem\"", BINOP_REM},
962 {"Oexpon", "\"**\"", BINOP_EXP},
963 {"Olt", "\"<\"", BINOP_LESS},
964 {"Ole", "\"<=\"", BINOP_LEQ},
965 {"Ogt", "\">\"", BINOP_GTR},
966 {"Oge", "\">=\"", BINOP_GEQ},
967 {"Oeq", "\"=\"", BINOP_EQUAL},
968 {"One", "\"/=\"", BINOP_NOTEQUAL},
969 {"Oand", "\"and\"", BINOP_BITWISE_AND},
970 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
971 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
972 {"Oconcat", "\"&\"", BINOP_CONCAT},
973 {"Oabs", "\"abs\"", UNOP_ABS},
974 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
975 {"Oadd", "\"+\"", UNOP_PLUS},
976 {"Osubtract", "\"-\"", UNOP_NEG},
977 {NULL, NULL}
978 };
979
980 /* The "encoded" form of DECODED, according to GNAT conventions. The
981 result is valid until the next call to ada_encode. If
982 THROW_ERRORS, throw an error if invalid operator name is found.
983 Otherwise, return NULL in that case. */
984
985 static char *
986 ada_encode_1 (const char *decoded, bool throw_errors)
987 {
988 static char *encoding_buffer = NULL;
989 static size_t encoding_buffer_size = 0;
990 const char *p;
991 int k;
992
993 if (decoded == NULL)
994 return NULL;
995
996 GROW_VECT (encoding_buffer, encoding_buffer_size,
997 2 * strlen (decoded) + 10);
998
999 k = 0;
1000 for (p = decoded; *p != '\0'; p += 1)
1001 {
1002 if (*p == '.')
1003 {
1004 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
1005 k += 2;
1006 }
1007 else if (*p == '"')
1008 {
1009 const struct ada_opname_map *mapping;
1010
1011 for (mapping = ada_opname_table;
1012 mapping->encoded != NULL
1013 && !startswith (p, mapping->decoded); mapping += 1)
1014 ;
1015 if (mapping->encoded == NULL)
1016 {
1017 if (throw_errors)
1018 error (_("invalid Ada operator name: %s"), p);
1019 else
1020 return NULL;
1021 }
1022 strcpy (encoding_buffer + k, mapping->encoded);
1023 k += strlen (mapping->encoded);
1024 break;
1025 }
1026 else
1027 {
1028 encoding_buffer[k] = *p;
1029 k += 1;
1030 }
1031 }
1032
1033 encoding_buffer[k] = '\0';
1034 return encoding_buffer;
1035 }
1036
1037 /* The "encoded" form of DECODED, according to GNAT conventions.
1038 The result is valid until the next call to ada_encode. */
1039
1040 char *
1041 ada_encode (const char *decoded)
1042 {
1043 return ada_encode_1 (decoded, true);
1044 }
1045
1046 /* Return NAME folded to lower case, or, if surrounded by single
1047 quotes, unfolded, but with the quotes stripped away. Result good
1048 to next call. */
1049
1050 char *
1051 ada_fold_name (const char *name)
1052 {
1053 static char *fold_buffer = NULL;
1054 static size_t fold_buffer_size = 0;
1055
1056 int len = strlen (name);
1057 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
1058
1059 if (name[0] == '\'')
1060 {
1061 strncpy (fold_buffer, name + 1, len - 2);
1062 fold_buffer[len - 2] = '\000';
1063 }
1064 else
1065 {
1066 int i;
1067
1068 for (i = 0; i <= len; i += 1)
1069 fold_buffer[i] = tolower (name[i]);
1070 }
1071
1072 return fold_buffer;
1073 }
1074
1075 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1076
1077 static int
1078 is_lower_alphanum (const char c)
1079 {
1080 return (isdigit (c) || (isalpha (c) && islower (c)));
1081 }
1082
1083 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1084 This function saves in LEN the length of that same symbol name but
1085 without either of these suffixes:
1086 . .{DIGIT}+
1087 . ${DIGIT}+
1088 . ___{DIGIT}+
1089 . __{DIGIT}+.
1090
1091 These are suffixes introduced by the compiler for entities such as
1092 nested subprogram for instance, in order to avoid name clashes.
1093 They do not serve any purpose for the debugger. */
1094
1095 static void
1096 ada_remove_trailing_digits (const char *encoded, int *len)
1097 {
1098 if (*len > 1 && isdigit (encoded[*len - 1]))
1099 {
1100 int i = *len - 2;
1101
1102 while (i > 0 && isdigit (encoded[i]))
1103 i--;
1104 if (i >= 0 && encoded[i] == '.')
1105 *len = i;
1106 else if (i >= 0 && encoded[i] == '$')
1107 *len = i;
1108 else if (i >= 2 && startswith (encoded + i - 2, "___"))
1109 *len = i - 2;
1110 else if (i >= 1 && startswith (encoded + i - 1, "__"))
1111 *len = i - 1;
1112 }
1113 }
1114
1115 /* Remove the suffix introduced by the compiler for protected object
1116 subprograms. */
1117
1118 static void
1119 ada_remove_po_subprogram_suffix (const char *encoded, int *len)
1120 {
1121 /* Remove trailing N. */
1122
1123 /* Protected entry subprograms are broken into two
1124 separate subprograms: The first one is unprotected, and has
1125 a 'N' suffix; the second is the protected version, and has
1126 the 'P' suffix. The second calls the first one after handling
1127 the protection. Since the P subprograms are internally generated,
1128 we leave these names undecoded, giving the user a clue that this
1129 entity is internal. */
1130
1131 if (*len > 1
1132 && encoded[*len - 1] == 'N'
1133 && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1134 *len = *len - 1;
1135 }
1136
1137 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1138
1139 static void
1140 ada_remove_Xbn_suffix (const char *encoded, int *len)
1141 {
1142 int i = *len - 1;
1143
1144 while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1145 i--;
1146
1147 if (encoded[i] != 'X')
1148 return;
1149
1150 if (i == 0)
1151 return;
1152
1153 if (isalnum (encoded[i-1]))
1154 *len = i;
1155 }
1156
1157 /* If ENCODED follows the GNAT entity encoding conventions, then return
1158 the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1159 replaced by ENCODED.
1160
1161 The resulting string is valid until the next call of ada_decode.
1162 If the string is unchanged by decoding, the original string pointer
1163 is returned. */
1164
1165 const char *
1166 ada_decode (const char *encoded)
1167 {
1168 int i, j;
1169 int len0;
1170 const char *p;
1171 char *decoded;
1172 int at_start_name;
1173 static char *decoding_buffer = NULL;
1174 static size_t decoding_buffer_size = 0;
1175
1176 /* The name of the Ada main procedure starts with "_ada_".
1177 This prefix is not part of the decoded name, so skip this part
1178 if we see this prefix. */
1179 if (startswith (encoded, "_ada_"))
1180 encoded += 5;
1181
1182 /* If the name starts with '_', then it is not a properly encoded
1183 name, so do not attempt to decode it. Similarly, if the name
1184 starts with '<', the name should not be decoded. */
1185 if (encoded[0] == '_' || encoded[0] == '<')
1186 goto Suppress;
1187
1188 len0 = strlen (encoded);
1189
1190 ada_remove_trailing_digits (encoded, &len0);
1191 ada_remove_po_subprogram_suffix (encoded, &len0);
1192
1193 /* Remove the ___X.* suffix if present. Do not forget to verify that
1194 the suffix is located before the current "end" of ENCODED. We want
1195 to avoid re-matching parts of ENCODED that have previously been
1196 marked as discarded (by decrementing LEN0). */
1197 p = strstr (encoded, "___");
1198 if (p != NULL && p - encoded < len0 - 3)
1199 {
1200 if (p[3] == 'X')
1201 len0 = p - encoded;
1202 else
1203 goto Suppress;
1204 }
1205
1206 /* Remove any trailing TKB suffix. It tells us that this symbol
1207 is for the body of a task, but that information does not actually
1208 appear in the decoded name. */
1209
1210 if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1211 len0 -= 3;
1212
1213 /* Remove any trailing TB suffix. The TB suffix is slightly different
1214 from the TKB suffix because it is used for non-anonymous task
1215 bodies. */
1216
1217 if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1218 len0 -= 2;
1219
1220 /* Remove trailing "B" suffixes. */
1221 /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1222
1223 if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1224 len0 -= 1;
1225
1226 /* Make decoded big enough for possible expansion by operator name. */
1227
1228 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1229 decoded = decoding_buffer;
1230
1231 /* Remove trailing __{digit}+ or trailing ${digit}+. */
1232
1233 if (len0 > 1 && isdigit (encoded[len0 - 1]))
1234 {
1235 i = len0 - 2;
1236 while ((i >= 0 && isdigit (encoded[i]))
1237 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1238 i -= 1;
1239 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1240 len0 = i - 1;
1241 else if (encoded[i] == '$')
1242 len0 = i;
1243 }
1244
1245 /* The first few characters that are not alphabetic are not part
1246 of any encoding we use, so we can copy them over verbatim. */
1247
1248 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1249 decoded[j] = encoded[i];
1250
1251 at_start_name = 1;
1252 while (i < len0)
1253 {
1254 /* Is this a symbol function? */
1255 if (at_start_name && encoded[i] == 'O')
1256 {
1257 int k;
1258
1259 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1260 {
1261 int op_len = strlen (ada_opname_table[k].encoded);
1262 if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1263 op_len - 1) == 0)
1264 && !isalnum (encoded[i + op_len]))
1265 {
1266 strcpy (decoded + j, ada_opname_table[k].decoded);
1267 at_start_name = 0;
1268 i += op_len;
1269 j += strlen (ada_opname_table[k].decoded);
1270 break;
1271 }
1272 }
1273 if (ada_opname_table[k].encoded != NULL)
1274 continue;
1275 }
1276 at_start_name = 0;
1277
1278 /* Replace "TK__" with "__", which will eventually be translated
1279 into "." (just below). */
1280
1281 if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1282 i += 2;
1283
1284 /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1285 be translated into "." (just below). These are internal names
1286 generated for anonymous blocks inside which our symbol is nested. */
1287
1288 if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1289 && encoded [i+2] == 'B' && encoded [i+3] == '_'
1290 && isdigit (encoded [i+4]))
1291 {
1292 int k = i + 5;
1293
1294 while (k < len0 && isdigit (encoded[k]))
1295 k++; /* Skip any extra digit. */
1296
1297 /* Double-check that the "__B_{DIGITS}+" sequence we found
1298 is indeed followed by "__". */
1299 if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1300 i = k;
1301 }
1302
1303 /* Remove _E{DIGITS}+[sb] */
1304
1305 /* Just as for protected object subprograms, there are 2 categories
1306 of subprograms created by the compiler for each entry. The first
1307 one implements the actual entry code, and has a suffix following
1308 the convention above; the second one implements the barrier and
1309 uses the same convention as above, except that the 'E' is replaced
1310 by a 'B'.
1311
1312 Just as above, we do not decode the name of barrier functions
1313 to give the user a clue that the code he is debugging has been
1314 internally generated. */
1315
1316 if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1317 && isdigit (encoded[i+2]))
1318 {
1319 int k = i + 3;
1320
1321 while (k < len0 && isdigit (encoded[k]))
1322 k++;
1323
1324 if (k < len0
1325 && (encoded[k] == 'b' || encoded[k] == 's'))
1326 {
1327 k++;
1328 /* Just as an extra precaution, make sure that if this
1329 suffix is followed by anything else, it is a '_'.
1330 Otherwise, we matched this sequence by accident. */
1331 if (k == len0
1332 || (k < len0 && encoded[k] == '_'))
1333 i = k;
1334 }
1335 }
1336
1337 /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1338 the GNAT front-end in protected object subprograms. */
1339
1340 if (i < len0 + 3
1341 && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1342 {
1343 /* Backtrack a bit up until we reach either the begining of
1344 the encoded name, or "__". Make sure that we only find
1345 digits or lowercase characters. */
1346 const char *ptr = encoded + i - 1;
1347
1348 while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1349 ptr--;
1350 if (ptr < encoded
1351 || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1352 i++;
1353 }
1354
1355 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1356 {
1357 /* This is a X[bn]* sequence not separated from the previous
1358 part of the name with a non-alpha-numeric character (in other
1359 words, immediately following an alpha-numeric character), then
1360 verify that it is placed at the end of the encoded name. If
1361 not, then the encoding is not valid and we should abort the
1362 decoding. Otherwise, just skip it, it is used in body-nested
1363 package names. */
1364 do
1365 i += 1;
1366 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1367 if (i < len0)
1368 goto Suppress;
1369 }
1370 else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1371 {
1372 /* Replace '__' by '.'. */
1373 decoded[j] = '.';
1374 at_start_name = 1;
1375 i += 2;
1376 j += 1;
1377 }
1378 else
1379 {
1380 /* It's a character part of the decoded name, so just copy it
1381 over. */
1382 decoded[j] = encoded[i];
1383 i += 1;
1384 j += 1;
1385 }
1386 }
1387 decoded[j] = '\000';
1388
1389 /* Decoded names should never contain any uppercase character.
1390 Double-check this, and abort the decoding if we find one. */
1391
1392 for (i = 0; decoded[i] != '\0'; i += 1)
1393 if (isupper (decoded[i]) || decoded[i] == ' ')
1394 goto Suppress;
1395
1396 if (strcmp (decoded, encoded) == 0)
1397 return encoded;
1398 else
1399 return decoded;
1400
1401 Suppress:
1402 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1403 decoded = decoding_buffer;
1404 if (encoded[0] == '<')
1405 strcpy (decoded, encoded);
1406 else
1407 xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1408 return decoded;
1409
1410 }
1411
1412 /* Table for keeping permanent unique copies of decoded names. Once
1413 allocated, names in this table are never released. While this is a
1414 storage leak, it should not be significant unless there are massive
1415 changes in the set of decoded names in successive versions of a
1416 symbol table loaded during a single session. */
1417 static struct htab *decoded_names_store;
1418
1419 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1420 in the language-specific part of GSYMBOL, if it has not been
1421 previously computed. Tries to save the decoded name in the same
1422 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1423 in any case, the decoded symbol has a lifetime at least that of
1424 GSYMBOL).
1425 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1426 const, but nevertheless modified to a semantically equivalent form
1427 when a decoded name is cached in it. */
1428
1429 const char *
1430 ada_decode_symbol (const struct general_symbol_info *arg)
1431 {
1432 struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1433 const char **resultp =
1434 &gsymbol->language_specific.demangled_name;
1435
1436 if (!gsymbol->ada_mangled)
1437 {
1438 const char *decoded = ada_decode (gsymbol->name);
1439 struct obstack *obstack = gsymbol->language_specific.obstack;
1440
1441 gsymbol->ada_mangled = 1;
1442
1443 if (obstack != NULL)
1444 *resultp
1445 = (const char *) obstack_copy0 (obstack, decoded, strlen (decoded));
1446 else
1447 {
1448 /* Sometimes, we can't find a corresponding objfile, in
1449 which case, we put the result on the heap. Since we only
1450 decode when needed, we hope this usually does not cause a
1451 significant memory leak (FIXME). */
1452
1453 char **slot = (char **) htab_find_slot (decoded_names_store,
1454 decoded, INSERT);
1455
1456 if (*slot == NULL)
1457 *slot = xstrdup (decoded);
1458 *resultp = *slot;
1459 }
1460 }
1461
1462 return *resultp;
1463 }
1464
1465 static char *
1466 ada_la_decode (const char *encoded, int options)
1467 {
1468 return xstrdup (ada_decode (encoded));
1469 }
1470
1471 /* Implement la_sniff_from_mangled_name for Ada. */
1472
1473 static int
1474 ada_sniff_from_mangled_name (const char *mangled, char **out)
1475 {
1476 const char *demangled = ada_decode (mangled);
1477
1478 *out = NULL;
1479
1480 if (demangled != mangled && demangled != NULL && demangled[0] != '<')
1481 {
1482 /* Set the gsymbol language to Ada, but still return 0.
1483 Two reasons for that:
1484
1485 1. For Ada, we prefer computing the symbol's decoded name
1486 on the fly rather than pre-compute it, in order to save
1487 memory (Ada projects are typically very large).
1488
1489 2. There are some areas in the definition of the GNAT
1490 encoding where, with a bit of bad luck, we might be able
1491 to decode a non-Ada symbol, generating an incorrect
1492 demangled name (Eg: names ending with "TB" for instance
1493 are identified as task bodies and so stripped from
1494 the decoded name returned).
1495
1496 Returning 1, here, but not setting *DEMANGLED, helps us get a
1497 little bit of the best of both worlds. Because we're last,
1498 we should not affect any of the other languages that were
1499 able to demangle the symbol before us; we get to correctly
1500 tag Ada symbols as such; and even if we incorrectly tagged a
1501 non-Ada symbol, which should be rare, any routing through the
1502 Ada language should be transparent (Ada tries to behave much
1503 like C/C++ with non-Ada symbols). */
1504 return 1;
1505 }
1506
1507 return 0;
1508 }
1509
1510
1511
1512 /* Arrays */
1513
1514 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1515 generated by the GNAT compiler to describe the index type used
1516 for each dimension of an array, check whether it follows the latest
1517 known encoding. If not, fix it up to conform to the latest encoding.
1518 Otherwise, do nothing. This function also does nothing if
1519 INDEX_DESC_TYPE is NULL.
1520
1521 The GNAT encoding used to describle the array index type evolved a bit.
1522 Initially, the information would be provided through the name of each
1523 field of the structure type only, while the type of these fields was
1524 described as unspecified and irrelevant. The debugger was then expected
1525 to perform a global type lookup using the name of that field in order
1526 to get access to the full index type description. Because these global
1527 lookups can be very expensive, the encoding was later enhanced to make
1528 the global lookup unnecessary by defining the field type as being
1529 the full index type description.
1530
1531 The purpose of this routine is to allow us to support older versions
1532 of the compiler by detecting the use of the older encoding, and by
1533 fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1534 we essentially replace each field's meaningless type by the associated
1535 index subtype). */
1536
1537 void
1538 ada_fixup_array_indexes_type (struct type *index_desc_type)
1539 {
1540 int i;
1541
1542 if (index_desc_type == NULL)
1543 return;
1544 gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1545
1546 /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1547 to check one field only, no need to check them all). If not, return
1548 now.
1549
1550 If our INDEX_DESC_TYPE was generated using the older encoding,
1551 the field type should be a meaningless integer type whose name
1552 is not equal to the field name. */
1553 if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1554 && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1555 TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1556 return;
1557
1558 /* Fixup each field of INDEX_DESC_TYPE. */
1559 for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1560 {
1561 const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1562 struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1563
1564 if (raw_type)
1565 TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1566 }
1567 }
1568
1569 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1570
1571 static const char *bound_name[] = {
1572 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1573 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1574 };
1575
1576 /* Maximum number of array dimensions we are prepared to handle. */
1577
1578 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1579
1580
1581 /* The desc_* routines return primitive portions of array descriptors
1582 (fat pointers). */
1583
1584 /* The descriptor or array type, if any, indicated by TYPE; removes
1585 level of indirection, if needed. */
1586
1587 static struct type *
1588 desc_base_type (struct type *type)
1589 {
1590 if (type == NULL)
1591 return NULL;
1592 type = ada_check_typedef (type);
1593 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1594 type = ada_typedef_target_type (type);
1595
1596 if (type != NULL
1597 && (TYPE_CODE (type) == TYPE_CODE_PTR
1598 || TYPE_CODE (type) == TYPE_CODE_REF))
1599 return ada_check_typedef (TYPE_TARGET_TYPE (type));
1600 else
1601 return type;
1602 }
1603
1604 /* True iff TYPE indicates a "thin" array pointer type. */
1605
1606 static int
1607 is_thin_pntr (struct type *type)
1608 {
1609 return
1610 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1611 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1612 }
1613
1614 /* The descriptor type for thin pointer type TYPE. */
1615
1616 static struct type *
1617 thin_descriptor_type (struct type *type)
1618 {
1619 struct type *base_type = desc_base_type (type);
1620
1621 if (base_type == NULL)
1622 return NULL;
1623 if (is_suffix (ada_type_name (base_type), "___XVE"))
1624 return base_type;
1625 else
1626 {
1627 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1628
1629 if (alt_type == NULL)
1630 return base_type;
1631 else
1632 return alt_type;
1633 }
1634 }
1635
1636 /* A pointer to the array data for thin-pointer value VAL. */
1637
1638 static struct value *
1639 thin_data_pntr (struct value *val)
1640 {
1641 struct type *type = ada_check_typedef (value_type (val));
1642 struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1643
1644 data_type = lookup_pointer_type (data_type);
1645
1646 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1647 return value_cast (data_type, value_copy (val));
1648 else
1649 return value_from_longest (data_type, value_address (val));
1650 }
1651
1652 /* True iff TYPE indicates a "thick" array pointer type. */
1653
1654 static int
1655 is_thick_pntr (struct type *type)
1656 {
1657 type = desc_base_type (type);
1658 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1659 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1660 }
1661
1662 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1663 pointer to one, the type of its bounds data; otherwise, NULL. */
1664
1665 static struct type *
1666 desc_bounds_type (struct type *type)
1667 {
1668 struct type *r;
1669
1670 type = desc_base_type (type);
1671
1672 if (type == NULL)
1673 return NULL;
1674 else if (is_thin_pntr (type))
1675 {
1676 type = thin_descriptor_type (type);
1677 if (type == NULL)
1678 return NULL;
1679 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1680 if (r != NULL)
1681 return ada_check_typedef (r);
1682 }
1683 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1684 {
1685 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1686 if (r != NULL)
1687 return ada_check_typedef (TYPE_TARGET_TYPE (ada_check_typedef (r)));
1688 }
1689 return NULL;
1690 }
1691
1692 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1693 one, a pointer to its bounds data. Otherwise NULL. */
1694
1695 static struct value *
1696 desc_bounds (struct value *arr)
1697 {
1698 struct type *type = ada_check_typedef (value_type (arr));
1699
1700 if (is_thin_pntr (type))
1701 {
1702 struct type *bounds_type =
1703 desc_bounds_type (thin_descriptor_type (type));
1704 LONGEST addr;
1705
1706 if (bounds_type == NULL)
1707 error (_("Bad GNAT array descriptor"));
1708
1709 /* NOTE: The following calculation is not really kosher, but
1710 since desc_type is an XVE-encoded type (and shouldn't be),
1711 the correct calculation is a real pain. FIXME (and fix GCC). */
1712 if (TYPE_CODE (type) == TYPE_CODE_PTR)
1713 addr = value_as_long (arr);
1714 else
1715 addr = value_address (arr);
1716
1717 return
1718 value_from_longest (lookup_pointer_type (bounds_type),
1719 addr - TYPE_LENGTH (bounds_type));
1720 }
1721
1722 else if (is_thick_pntr (type))
1723 {
1724 struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1725 _("Bad GNAT array descriptor"));
1726 struct type *p_bounds_type = value_type (p_bounds);
1727
1728 if (p_bounds_type
1729 && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1730 {
1731 struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1732
1733 if (TYPE_STUB (target_type))
1734 p_bounds = value_cast (lookup_pointer_type
1735 (ada_check_typedef (target_type)),
1736 p_bounds);
1737 }
1738 else
1739 error (_("Bad GNAT array descriptor"));
1740
1741 return p_bounds;
1742 }
1743 else
1744 return NULL;
1745 }
1746
1747 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1748 position of the field containing the address of the bounds data. */
1749
1750 static int
1751 fat_pntr_bounds_bitpos (struct type *type)
1752 {
1753 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1754 }
1755
1756 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1757 size of the field containing the address of the bounds data. */
1758
1759 static int
1760 fat_pntr_bounds_bitsize (struct type *type)
1761 {
1762 type = desc_base_type (type);
1763
1764 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1765 return TYPE_FIELD_BITSIZE (type, 1);
1766 else
1767 return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1768 }
1769
1770 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1771 pointer to one, the type of its array data (a array-with-no-bounds type);
1772 otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1773 data. */
1774
1775 static struct type *
1776 desc_data_target_type (struct type *type)
1777 {
1778 type = desc_base_type (type);
1779
1780 /* NOTE: The following is bogus; see comment in desc_bounds. */
1781 if (is_thin_pntr (type))
1782 return desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1));
1783 else if (is_thick_pntr (type))
1784 {
1785 struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1786
1787 if (data_type
1788 && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1789 return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1790 }
1791
1792 return NULL;
1793 }
1794
1795 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1796 its array data. */
1797
1798 static struct value *
1799 desc_data (struct value *arr)
1800 {
1801 struct type *type = value_type (arr);
1802
1803 if (is_thin_pntr (type))
1804 return thin_data_pntr (arr);
1805 else if (is_thick_pntr (type))
1806 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1807 _("Bad GNAT array descriptor"));
1808 else
1809 return NULL;
1810 }
1811
1812
1813 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1814 position of the field containing the address of the data. */
1815
1816 static int
1817 fat_pntr_data_bitpos (struct type *type)
1818 {
1819 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1820 }
1821
1822 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1823 size of the field containing the address of the data. */
1824
1825 static int
1826 fat_pntr_data_bitsize (struct type *type)
1827 {
1828 type = desc_base_type (type);
1829
1830 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1831 return TYPE_FIELD_BITSIZE (type, 0);
1832 else
1833 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1834 }
1835
1836 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1837 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1838 bound, if WHICH is 1. The first bound is I=1. */
1839
1840 static struct value *
1841 desc_one_bound (struct value *bounds, int i, int which)
1842 {
1843 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1844 _("Bad GNAT array descriptor bounds"));
1845 }
1846
1847 /* If BOUNDS is an array-bounds structure type, return the bit position
1848 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1849 bound, if WHICH is 1. The first bound is I=1. */
1850
1851 static int
1852 desc_bound_bitpos (struct type *type, int i, int which)
1853 {
1854 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1855 }
1856
1857 /* If BOUNDS is an array-bounds structure type, return the bit field size
1858 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1859 bound, if WHICH is 1. The first bound is I=1. */
1860
1861 static int
1862 desc_bound_bitsize (struct type *type, int i, int which)
1863 {
1864 type = desc_base_type (type);
1865
1866 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1867 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1868 else
1869 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1870 }
1871
1872 /* If TYPE is the type of an array-bounds structure, the type of its
1873 Ith bound (numbering from 1). Otherwise, NULL. */
1874
1875 static struct type *
1876 desc_index_type (struct type *type, int i)
1877 {
1878 type = desc_base_type (type);
1879
1880 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1881 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1882 else
1883 return NULL;
1884 }
1885
1886 /* The number of index positions in the array-bounds type TYPE.
1887 Return 0 if TYPE is NULL. */
1888
1889 static int
1890 desc_arity (struct type *type)
1891 {
1892 type = desc_base_type (type);
1893
1894 if (type != NULL)
1895 return TYPE_NFIELDS (type) / 2;
1896 return 0;
1897 }
1898
1899 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1900 an array descriptor type (representing an unconstrained array
1901 type). */
1902
1903 static int
1904 ada_is_direct_array_type (struct type *type)
1905 {
1906 if (type == NULL)
1907 return 0;
1908 type = ada_check_typedef (type);
1909 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1910 || ada_is_array_descriptor_type (type));
1911 }
1912
1913 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1914 * to one. */
1915
1916 static int
1917 ada_is_array_type (struct type *type)
1918 {
1919 while (type != NULL
1920 && (TYPE_CODE (type) == TYPE_CODE_PTR
1921 || TYPE_CODE (type) == TYPE_CODE_REF))
1922 type = TYPE_TARGET_TYPE (type);
1923 return ada_is_direct_array_type (type);
1924 }
1925
1926 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1927
1928 int
1929 ada_is_simple_array_type (struct type *type)
1930 {
1931 if (type == NULL)
1932 return 0;
1933 type = ada_check_typedef (type);
1934 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1935 || (TYPE_CODE (type) == TYPE_CODE_PTR
1936 && TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type)))
1937 == TYPE_CODE_ARRAY));
1938 }
1939
1940 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1941
1942 int
1943 ada_is_array_descriptor_type (struct type *type)
1944 {
1945 struct type *data_type = desc_data_target_type (type);
1946
1947 if (type == NULL)
1948 return 0;
1949 type = ada_check_typedef (type);
1950 return (data_type != NULL
1951 && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1952 && desc_arity (desc_bounds_type (type)) > 0);
1953 }
1954
1955 /* Non-zero iff type is a partially mal-formed GNAT array
1956 descriptor. FIXME: This is to compensate for some problems with
1957 debugging output from GNAT. Re-examine periodically to see if it
1958 is still needed. */
1959
1960 int
1961 ada_is_bogus_array_descriptor (struct type *type)
1962 {
1963 return
1964 type != NULL
1965 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1966 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1967 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1968 && !ada_is_array_descriptor_type (type);
1969 }
1970
1971
1972 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1973 (fat pointer) returns the type of the array data described---specifically,
1974 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1975 in from the descriptor; otherwise, they are left unspecified. If
1976 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1977 returns NULL. The result is simply the type of ARR if ARR is not
1978 a descriptor. */
1979 struct type *
1980 ada_type_of_array (struct value *arr, int bounds)
1981 {
1982 if (ada_is_constrained_packed_array_type (value_type (arr)))
1983 return decode_constrained_packed_array_type (value_type (arr));
1984
1985 if (!ada_is_array_descriptor_type (value_type (arr)))
1986 return value_type (arr);
1987
1988 if (!bounds)
1989 {
1990 struct type *array_type =
1991 ada_check_typedef (desc_data_target_type (value_type (arr)));
1992
1993 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
1994 TYPE_FIELD_BITSIZE (array_type, 0) =
1995 decode_packed_array_bitsize (value_type (arr));
1996
1997 return array_type;
1998 }
1999 else
2000 {
2001 struct type *elt_type;
2002 int arity;
2003 struct value *descriptor;
2004
2005 elt_type = ada_array_element_type (value_type (arr), -1);
2006 arity = ada_array_arity (value_type (arr));
2007
2008 if (elt_type == NULL || arity == 0)
2009 return ada_check_typedef (value_type (arr));
2010
2011 descriptor = desc_bounds (arr);
2012 if (value_as_long (descriptor) == 0)
2013 return NULL;
2014 while (arity > 0)
2015 {
2016 struct type *range_type = alloc_type_copy (value_type (arr));
2017 struct type *array_type = alloc_type_copy (value_type (arr));
2018 struct value *low = desc_one_bound (descriptor, arity, 0);
2019 struct value *high = desc_one_bound (descriptor, arity, 1);
2020
2021 arity -= 1;
2022 create_static_range_type (range_type, value_type (low),
2023 longest_to_int (value_as_long (low)),
2024 longest_to_int (value_as_long (high)));
2025 elt_type = create_array_type (array_type, elt_type, range_type);
2026
2027 if (ada_is_unconstrained_packed_array_type (value_type (arr)))
2028 {
2029 /* We need to store the element packed bitsize, as well as
2030 recompute the array size, because it was previously
2031 computed based on the unpacked element size. */
2032 LONGEST lo = value_as_long (low);
2033 LONGEST hi = value_as_long (high);
2034
2035 TYPE_FIELD_BITSIZE (elt_type, 0) =
2036 decode_packed_array_bitsize (value_type (arr));
2037 /* If the array has no element, then the size is already
2038 zero, and does not need to be recomputed. */
2039 if (lo < hi)
2040 {
2041 int array_bitsize =
2042 (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2043
2044 TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2045 }
2046 }
2047 }
2048
2049 return lookup_pointer_type (elt_type);
2050 }
2051 }
2052
2053 /* If ARR does not represent an array, returns ARR unchanged.
2054 Otherwise, returns either a standard GDB array with bounds set
2055 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2056 GDB array. Returns NULL if ARR is a null fat pointer. */
2057
2058 struct value *
2059 ada_coerce_to_simple_array_ptr (struct value *arr)
2060 {
2061 if (ada_is_array_descriptor_type (value_type (arr)))
2062 {
2063 struct type *arrType = ada_type_of_array (arr, 1);
2064
2065 if (arrType == NULL)
2066 return NULL;
2067 return value_cast (arrType, value_copy (desc_data (arr)));
2068 }
2069 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2070 return decode_constrained_packed_array (arr);
2071 else
2072 return arr;
2073 }
2074
2075 /* If ARR does not represent an array, returns ARR unchanged.
2076 Otherwise, returns a standard GDB array describing ARR (which may
2077 be ARR itself if it already is in the proper form). */
2078
2079 struct value *
2080 ada_coerce_to_simple_array (struct value *arr)
2081 {
2082 if (ada_is_array_descriptor_type (value_type (arr)))
2083 {
2084 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2085
2086 if (arrVal == NULL)
2087 error (_("Bounds unavailable for null array pointer."));
2088 ada_ensure_varsize_limit (TYPE_TARGET_TYPE (value_type (arrVal)));
2089 return value_ind (arrVal);
2090 }
2091 else if (ada_is_constrained_packed_array_type (value_type (arr)))
2092 return decode_constrained_packed_array (arr);
2093 else
2094 return arr;
2095 }
2096
2097 /* If TYPE represents a GNAT array type, return it translated to an
2098 ordinary GDB array type (possibly with BITSIZE fields indicating
2099 packing). For other types, is the identity. */
2100
2101 struct type *
2102 ada_coerce_to_simple_array_type (struct type *type)
2103 {
2104 if (ada_is_constrained_packed_array_type (type))
2105 return decode_constrained_packed_array_type (type);
2106
2107 if (ada_is_array_descriptor_type (type))
2108 return ada_check_typedef (desc_data_target_type (type));
2109
2110 return type;
2111 }
2112
2113 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2114
2115 static int
2116 ada_is_packed_array_type (struct type *type)
2117 {
2118 if (type == NULL)
2119 return 0;
2120 type = desc_base_type (type);
2121 type = ada_check_typedef (type);
2122 return
2123 ada_type_name (type) != NULL
2124 && strstr (ada_type_name (type), "___XP") != NULL;
2125 }
2126
2127 /* Non-zero iff TYPE represents a standard GNAT constrained
2128 packed-array type. */
2129
2130 int
2131 ada_is_constrained_packed_array_type (struct type *type)
2132 {
2133 return ada_is_packed_array_type (type)
2134 && !ada_is_array_descriptor_type (type);
2135 }
2136
2137 /* Non-zero iff TYPE represents an array descriptor for a
2138 unconstrained packed-array type. */
2139
2140 static int
2141 ada_is_unconstrained_packed_array_type (struct type *type)
2142 {
2143 return ada_is_packed_array_type (type)
2144 && ada_is_array_descriptor_type (type);
2145 }
2146
2147 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2148 return the size of its elements in bits. */
2149
2150 static long
2151 decode_packed_array_bitsize (struct type *type)
2152 {
2153 const char *raw_name;
2154 const char *tail;
2155 long bits;
2156
2157 /* Access to arrays implemented as fat pointers are encoded as a typedef
2158 of the fat pointer type. We need the name of the fat pointer type
2159 to do the decoding, so strip the typedef layer. */
2160 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2161 type = ada_typedef_target_type (type);
2162
2163 raw_name = ada_type_name (ada_check_typedef (type));
2164 if (!raw_name)
2165 raw_name = ada_type_name (desc_base_type (type));
2166
2167 if (!raw_name)
2168 return 0;
2169
2170 tail = strstr (raw_name, "___XP");
2171 gdb_assert (tail != NULL);
2172
2173 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2174 {
2175 lim_warning
2176 (_("could not understand bit size information on packed array"));
2177 return 0;
2178 }
2179
2180 return bits;
2181 }
2182
2183 /* Given that TYPE is a standard GDB array type with all bounds filled
2184 in, and that the element size of its ultimate scalar constituents
2185 (that is, either its elements, or, if it is an array of arrays, its
2186 elements' elements, etc.) is *ELT_BITS, return an identical type,
2187 but with the bit sizes of its elements (and those of any
2188 constituent arrays) recorded in the BITSIZE components of its
2189 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2190 in bits.
2191
2192 Note that, for arrays whose index type has an XA encoding where
2193 a bound references a record discriminant, getting that discriminant,
2194 and therefore the actual value of that bound, is not possible
2195 because none of the given parameters gives us access to the record.
2196 This function assumes that it is OK in the context where it is being
2197 used to return an array whose bounds are still dynamic and where
2198 the length is arbitrary. */
2199
2200 static struct type *
2201 constrained_packed_array_type (struct type *type, long *elt_bits)
2202 {
2203 struct type *new_elt_type;
2204 struct type *new_type;
2205 struct type *index_type_desc;
2206 struct type *index_type;
2207 LONGEST low_bound, high_bound;
2208
2209 type = ada_check_typedef (type);
2210 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2211 return type;
2212
2213 index_type_desc = ada_find_parallel_type (type, "___XA");
2214 if (index_type_desc)
2215 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2216 NULL);
2217 else
2218 index_type = TYPE_INDEX_TYPE (type);
2219
2220 new_type = alloc_type_copy (type);
2221 new_elt_type =
2222 constrained_packed_array_type (ada_check_typedef (TYPE_TARGET_TYPE (type)),
2223 elt_bits);
2224 create_array_type (new_type, new_elt_type, index_type);
2225 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2226 TYPE_NAME (new_type) = ada_type_name (type);
2227
2228 if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2229 && is_dynamic_type (check_typedef (index_type)))
2230 || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2231 low_bound = high_bound = 0;
2232 if (high_bound < low_bound)
2233 *elt_bits = TYPE_LENGTH (new_type) = 0;
2234 else
2235 {
2236 *elt_bits *= (high_bound - low_bound + 1);
2237 TYPE_LENGTH (new_type) =
2238 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2239 }
2240
2241 TYPE_FIXED_INSTANCE (new_type) = 1;
2242 return new_type;
2243 }
2244
2245 /* The array type encoded by TYPE, where
2246 ada_is_constrained_packed_array_type (TYPE). */
2247
2248 static struct type *
2249 decode_constrained_packed_array_type (struct type *type)
2250 {
2251 const char *raw_name = ada_type_name (ada_check_typedef (type));
2252 char *name;
2253 const char *tail;
2254 struct type *shadow_type;
2255 long bits;
2256
2257 if (!raw_name)
2258 raw_name = ada_type_name (desc_base_type (type));
2259
2260 if (!raw_name)
2261 return NULL;
2262
2263 name = (char *) alloca (strlen (raw_name) + 1);
2264 tail = strstr (raw_name, "___XP");
2265 type = desc_base_type (type);
2266
2267 memcpy (name, raw_name, tail - raw_name);
2268 name[tail - raw_name] = '\000';
2269
2270 shadow_type = ada_find_parallel_type_with_name (type, name);
2271
2272 if (shadow_type == NULL)
2273 {
2274 lim_warning (_("could not find bounds information on packed array"));
2275 return NULL;
2276 }
2277 shadow_type = check_typedef (shadow_type);
2278
2279 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2280 {
2281 lim_warning (_("could not understand bounds "
2282 "information on packed array"));
2283 return NULL;
2284 }
2285
2286 bits = decode_packed_array_bitsize (type);
2287 return constrained_packed_array_type (shadow_type, &bits);
2288 }
2289
2290 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2291 array, returns a simple array that denotes that array. Its type is a
2292 standard GDB array type except that the BITSIZEs of the array
2293 target types are set to the number of bits in each element, and the
2294 type length is set appropriately. */
2295
2296 static struct value *
2297 decode_constrained_packed_array (struct value *arr)
2298 {
2299 struct type *type;
2300
2301 /* If our value is a pointer, then dereference it. Likewise if
2302 the value is a reference. Make sure that this operation does not
2303 cause the target type to be fixed, as this would indirectly cause
2304 this array to be decoded. The rest of the routine assumes that
2305 the array hasn't been decoded yet, so we use the basic "coerce_ref"
2306 and "value_ind" routines to perform the dereferencing, as opposed
2307 to using "ada_coerce_ref" or "ada_value_ind". */
2308 arr = coerce_ref (arr);
2309 if (TYPE_CODE (ada_check_typedef (value_type (arr))) == TYPE_CODE_PTR)
2310 arr = value_ind (arr);
2311
2312 type = decode_constrained_packed_array_type (value_type (arr));
2313 if (type == NULL)
2314 {
2315 error (_("can't unpack array"));
2316 return NULL;
2317 }
2318
2319 if (gdbarch_bits_big_endian (get_type_arch (value_type (arr)))
2320 && ada_is_modular_type (value_type (arr)))
2321 {
2322 /* This is a (right-justified) modular type representing a packed
2323 array with no wrapper. In order to interpret the value through
2324 the (left-justified) packed array type we just built, we must
2325 first left-justify it. */
2326 int bit_size, bit_pos;
2327 ULONGEST mod;
2328
2329 mod = ada_modulus (value_type (arr)) - 1;
2330 bit_size = 0;
2331 while (mod > 0)
2332 {
2333 bit_size += 1;
2334 mod >>= 1;
2335 }
2336 bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2337 arr = ada_value_primitive_packed_val (arr, NULL,
2338 bit_pos / HOST_CHAR_BIT,
2339 bit_pos % HOST_CHAR_BIT,
2340 bit_size,
2341 type);
2342 }
2343
2344 return coerce_unspec_val_to_type (arr, type);
2345 }
2346
2347
2348 /* The value of the element of packed array ARR at the ARITY indices
2349 given in IND. ARR must be a simple array. */
2350
2351 static struct value *
2352 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2353 {
2354 int i;
2355 int bits, elt_off, bit_off;
2356 long elt_total_bit_offset;
2357 struct type *elt_type;
2358 struct value *v;
2359
2360 bits = 0;
2361 elt_total_bit_offset = 0;
2362 elt_type = ada_check_typedef (value_type (arr));
2363 for (i = 0; i < arity; i += 1)
2364 {
2365 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2366 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2367 error
2368 (_("attempt to do packed indexing of "
2369 "something other than a packed array"));
2370 else
2371 {
2372 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2373 LONGEST lowerbound, upperbound;
2374 LONGEST idx;
2375
2376 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2377 {
2378 lim_warning (_("don't know bounds of array"));
2379 lowerbound = upperbound = 0;
2380 }
2381
2382 idx = pos_atr (ind[i]);
2383 if (idx < lowerbound || idx > upperbound)
2384 lim_warning (_("packed array index %ld out of bounds"),
2385 (long) idx);
2386 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2387 elt_total_bit_offset += (idx - lowerbound) * bits;
2388 elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2389 }
2390 }
2391 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2392 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2393
2394 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2395 bits, elt_type);
2396 return v;
2397 }
2398
2399 /* Non-zero iff TYPE includes negative integer values. */
2400
2401 static int
2402 has_negatives (struct type *type)
2403 {
2404 switch (TYPE_CODE (type))
2405 {
2406 default:
2407 return 0;
2408 case TYPE_CODE_INT:
2409 return !TYPE_UNSIGNED (type);
2410 case TYPE_CODE_RANGE:
2411 return TYPE_LOW_BOUND (type) < 0;
2412 }
2413 }
2414
2415 /* With SRC being a buffer containing BIT_SIZE bits of data at BIT_OFFSET,
2416 unpack that data into UNPACKED. UNPACKED_LEN is the size in bytes of
2417 the unpacked buffer.
2418
2419 The size of the unpacked buffer (UNPACKED_LEN) is expected to be large
2420 enough to contain at least BIT_OFFSET bits. If not, an error is raised.
2421
2422 IS_BIG_ENDIAN is nonzero if the data is stored in big endian mode,
2423 zero otherwise.
2424
2425 IS_SIGNED_TYPE is nonzero if the data corresponds to a signed type.
2426
2427 IS_SCALAR is nonzero if the data corresponds to a signed type. */
2428
2429 static void
2430 ada_unpack_from_contents (const gdb_byte *src, int bit_offset, int bit_size,
2431 gdb_byte *unpacked, int unpacked_len,
2432 int is_big_endian, int is_signed_type,
2433 int is_scalar)
2434 {
2435 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2436 int src_idx; /* Index into the source area */
2437 int src_bytes_left; /* Number of source bytes left to process. */
2438 int srcBitsLeft; /* Number of source bits left to move */
2439 int unusedLS; /* Number of bits in next significant
2440 byte of source that are unused */
2441
2442 int unpacked_idx; /* Index into the unpacked buffer */
2443 int unpacked_bytes_left; /* Number of bytes left to set in unpacked. */
2444
2445 unsigned long accum; /* Staging area for bits being transferred */
2446 int accumSize; /* Number of meaningful bits in accum */
2447 unsigned char sign;
2448
2449 /* Transmit bytes from least to most significant; delta is the direction
2450 the indices move. */
2451 int delta = is_big_endian ? -1 : 1;
2452
2453 /* Make sure that unpacked is large enough to receive the BIT_SIZE
2454 bits from SRC. .*/
2455 if ((bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT > unpacked_len)
2456 error (_("Cannot unpack %d bits into buffer of %d bytes"),
2457 bit_size, unpacked_len);
2458
2459 srcBitsLeft = bit_size;
2460 src_bytes_left = src_len;
2461 unpacked_bytes_left = unpacked_len;
2462 sign = 0;
2463
2464 if (is_big_endian)
2465 {
2466 src_idx = src_len - 1;
2467 if (is_signed_type
2468 && ((src[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2469 sign = ~0;
2470
2471 unusedLS =
2472 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2473 % HOST_CHAR_BIT;
2474
2475 if (is_scalar)
2476 {
2477 accumSize = 0;
2478 unpacked_idx = unpacked_len - 1;
2479 }
2480 else
2481 {
2482 /* Non-scalar values must be aligned at a byte boundary... */
2483 accumSize =
2484 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2485 /* ... And are placed at the beginning (most-significant) bytes
2486 of the target. */
2487 unpacked_idx = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2488 unpacked_bytes_left = unpacked_idx + 1;
2489 }
2490 }
2491 else
2492 {
2493 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2494
2495 src_idx = unpacked_idx = 0;
2496 unusedLS = bit_offset;
2497 accumSize = 0;
2498
2499 if (is_signed_type && (src[src_len - 1] & (1 << sign_bit_offset)))
2500 sign = ~0;
2501 }
2502
2503 accum = 0;
2504 while (src_bytes_left > 0)
2505 {
2506 /* Mask for removing bits of the next source byte that are not
2507 part of the value. */
2508 unsigned int unusedMSMask =
2509 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2510 1;
2511 /* Sign-extend bits for this byte. */
2512 unsigned int signMask = sign & ~unusedMSMask;
2513
2514 accum |=
2515 (((src[src_idx] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2516 accumSize += HOST_CHAR_BIT - unusedLS;
2517 if (accumSize >= HOST_CHAR_BIT)
2518 {
2519 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2520 accumSize -= HOST_CHAR_BIT;
2521 accum >>= HOST_CHAR_BIT;
2522 unpacked_bytes_left -= 1;
2523 unpacked_idx += delta;
2524 }
2525 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2526 unusedLS = 0;
2527 src_bytes_left -= 1;
2528 src_idx += delta;
2529 }
2530 while (unpacked_bytes_left > 0)
2531 {
2532 accum |= sign << accumSize;
2533 unpacked[unpacked_idx] = accum & ~(~0UL << HOST_CHAR_BIT);
2534 accumSize -= HOST_CHAR_BIT;
2535 if (accumSize < 0)
2536 accumSize = 0;
2537 accum >>= HOST_CHAR_BIT;
2538 unpacked_bytes_left -= 1;
2539 unpacked_idx += delta;
2540 }
2541 }
2542
2543 /* Create a new value of type TYPE from the contents of OBJ starting
2544 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2545 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2546 assigning through the result will set the field fetched from.
2547 VALADDR is ignored unless OBJ is NULL, in which case,
2548 VALADDR+OFFSET must address the start of storage containing the
2549 packed value. The value returned in this case is never an lval.
2550 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2551
2552 struct value *
2553 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2554 long offset, int bit_offset, int bit_size,
2555 struct type *type)
2556 {
2557 struct value *v;
2558 const gdb_byte *src; /* First byte containing data to unpack */
2559 gdb_byte *unpacked;
2560 const int is_scalar = is_scalar_type (type);
2561 const int is_big_endian = gdbarch_bits_big_endian (get_type_arch (type));
2562 gdb::byte_vector staging;
2563
2564 type = ada_check_typedef (type);
2565
2566 if (obj == NULL)
2567 src = valaddr + offset;
2568 else
2569 src = value_contents (obj) + offset;
2570
2571 if (is_dynamic_type (type))
2572 {
2573 /* The length of TYPE might by dynamic, so we need to resolve
2574 TYPE in order to know its actual size, which we then use
2575 to create the contents buffer of the value we return.
2576 The difficulty is that the data containing our object is
2577 packed, and therefore maybe not at a byte boundary. So, what
2578 we do, is unpack the data into a byte-aligned buffer, and then
2579 use that buffer as our object's value for resolving the type. */
2580 int staging_len = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2581 staging.resize (staging_len);
2582
2583 ada_unpack_from_contents (src, bit_offset, bit_size,
2584 staging.data (), staging.size (),
2585 is_big_endian, has_negatives (type),
2586 is_scalar);
2587 type = resolve_dynamic_type (type, staging.data (), 0);
2588 if (TYPE_LENGTH (type) < (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT)
2589 {
2590 /* This happens when the length of the object is dynamic,
2591 and is actually smaller than the space reserved for it.
2592 For instance, in an array of variant records, the bit_size
2593 we're given is the array stride, which is constant and
2594 normally equal to the maximum size of its element.
2595 But, in reality, each element only actually spans a portion
2596 of that stride. */
2597 bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2598 }
2599 }
2600
2601 if (obj == NULL)
2602 {
2603 v = allocate_value (type);
2604 src = valaddr + offset;
2605 }
2606 else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2607 {
2608 int src_len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2609 gdb_byte *buf;
2610
2611 v = value_at (type, value_address (obj) + offset);
2612 buf = (gdb_byte *) alloca (src_len);
2613 read_memory (value_address (v), buf, src_len);
2614 src = buf;
2615 }
2616 else
2617 {
2618 v = allocate_value (type);
2619 src = value_contents (obj) + offset;
2620 }
2621
2622 if (obj != NULL)
2623 {
2624 long new_offset = offset;
2625
2626 set_value_component_location (v, obj);
2627 set_value_bitpos (v, bit_offset + value_bitpos (obj));
2628 set_value_bitsize (v, bit_size);
2629 if (value_bitpos (v) >= HOST_CHAR_BIT)
2630 {
2631 ++new_offset;
2632 set_value_bitpos (v, value_bitpos (v) - HOST_CHAR_BIT);
2633 }
2634 set_value_offset (v, new_offset);
2635
2636 /* Also set the parent value. This is needed when trying to
2637 assign a new value (in inferior memory). */
2638 set_value_parent (v, obj);
2639 }
2640 else
2641 set_value_bitsize (v, bit_size);
2642 unpacked = value_contents_writeable (v);
2643
2644 if (bit_size == 0)
2645 {
2646 memset (unpacked, 0, TYPE_LENGTH (type));
2647 return v;
2648 }
2649
2650 if (staging.size () == TYPE_LENGTH (type))
2651 {
2652 /* Small short-cut: If we've unpacked the data into a buffer
2653 of the same size as TYPE's length, then we can reuse that,
2654 instead of doing the unpacking again. */
2655 memcpy (unpacked, staging.data (), staging.size ());
2656 }
2657 else
2658 ada_unpack_from_contents (src, bit_offset, bit_size,
2659 unpacked, TYPE_LENGTH (type),
2660 is_big_endian, has_negatives (type), is_scalar);
2661
2662 return v;
2663 }
2664
2665 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2666 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2667 not overlap. */
2668 static void
2669 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2670 int src_offset, int n, int bits_big_endian_p)
2671 {
2672 unsigned int accum, mask;
2673 int accum_bits, chunk_size;
2674
2675 target += targ_offset / HOST_CHAR_BIT;
2676 targ_offset %= HOST_CHAR_BIT;
2677 source += src_offset / HOST_CHAR_BIT;
2678 src_offset %= HOST_CHAR_BIT;
2679 if (bits_big_endian_p)
2680 {
2681 accum = (unsigned char) *source;
2682 source += 1;
2683 accum_bits = HOST_CHAR_BIT - src_offset;
2684
2685 while (n > 0)
2686 {
2687 int unused_right;
2688
2689 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2690 accum_bits += HOST_CHAR_BIT;
2691 source += 1;
2692 chunk_size = HOST_CHAR_BIT - targ_offset;
2693 if (chunk_size > n)
2694 chunk_size = n;
2695 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2696 mask = ((1 << chunk_size) - 1) << unused_right;
2697 *target =
2698 (*target & ~mask)
2699 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2700 n -= chunk_size;
2701 accum_bits -= chunk_size;
2702 target += 1;
2703 targ_offset = 0;
2704 }
2705 }
2706 else
2707 {
2708 accum = (unsigned char) *source >> src_offset;
2709 source += 1;
2710 accum_bits = HOST_CHAR_BIT - src_offset;
2711
2712 while (n > 0)
2713 {
2714 accum = accum + ((unsigned char) *source << accum_bits);
2715 accum_bits += HOST_CHAR_BIT;
2716 source += 1;
2717 chunk_size = HOST_CHAR_BIT - targ_offset;
2718 if (chunk_size > n)
2719 chunk_size = n;
2720 mask = ((1 << chunk_size) - 1) << targ_offset;
2721 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2722 n -= chunk_size;
2723 accum_bits -= chunk_size;
2724 accum >>= chunk_size;
2725 target += 1;
2726 targ_offset = 0;
2727 }
2728 }
2729 }
2730
2731 /* Store the contents of FROMVAL into the location of TOVAL.
2732 Return a new value with the location of TOVAL and contents of
2733 FROMVAL. Handles assignment into packed fields that have
2734 floating-point or non-scalar types. */
2735
2736 static struct value *
2737 ada_value_assign (struct value *toval, struct value *fromval)
2738 {
2739 struct type *type = value_type (toval);
2740 int bits = value_bitsize (toval);
2741
2742 toval = ada_coerce_ref (toval);
2743 fromval = ada_coerce_ref (fromval);
2744
2745 if (ada_is_direct_array_type (value_type (toval)))
2746 toval = ada_coerce_to_simple_array (toval);
2747 if (ada_is_direct_array_type (value_type (fromval)))
2748 fromval = ada_coerce_to_simple_array (fromval);
2749
2750 if (!deprecated_value_modifiable (toval))
2751 error (_("Left operand of assignment is not a modifiable lvalue."));
2752
2753 if (VALUE_LVAL (toval) == lval_memory
2754 && bits > 0
2755 && (TYPE_CODE (type) == TYPE_CODE_FLT
2756 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2757 {
2758 int len = (value_bitpos (toval)
2759 + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2760 int from_size;
2761 gdb_byte *buffer = (gdb_byte *) alloca (len);
2762 struct value *val;
2763 CORE_ADDR to_addr = value_address (toval);
2764
2765 if (TYPE_CODE (type) == TYPE_CODE_FLT)
2766 fromval = value_cast (type, fromval);
2767
2768 read_memory (to_addr, buffer, len);
2769 from_size = value_bitsize (fromval);
2770 if (from_size == 0)
2771 from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2772 if (gdbarch_bits_big_endian (get_type_arch (type)))
2773 move_bits (buffer, value_bitpos (toval),
2774 value_contents (fromval), from_size - bits, bits, 1);
2775 else
2776 move_bits (buffer, value_bitpos (toval),
2777 value_contents (fromval), 0, bits, 0);
2778 write_memory_with_notification (to_addr, buffer, len);
2779
2780 val = value_copy (toval);
2781 memcpy (value_contents_raw (val), value_contents (fromval),
2782 TYPE_LENGTH (type));
2783 deprecated_set_value_type (val, type);
2784
2785 return val;
2786 }
2787
2788 return value_assign (toval, fromval);
2789 }
2790
2791
2792 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2793 CONTAINER, assign the contents of VAL to COMPONENTS's place in
2794 CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2795 COMPONENT, and not the inferior's memory. The current contents
2796 of COMPONENT are ignored.
2797
2798 Although not part of the initial design, this function also works
2799 when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2800 had a null address, and COMPONENT had an address which is equal to
2801 its offset inside CONTAINER. */
2802
2803 static void
2804 value_assign_to_component (struct value *container, struct value *component,
2805 struct value *val)
2806 {
2807 LONGEST offset_in_container =
2808 (LONGEST) (value_address (component) - value_address (container));
2809 int bit_offset_in_container =
2810 value_bitpos (component) - value_bitpos (container);
2811 int bits;
2812
2813 val = value_cast (value_type (component), val);
2814
2815 if (value_bitsize (component) == 0)
2816 bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2817 else
2818 bits = value_bitsize (component);
2819
2820 if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2821 move_bits (value_contents_writeable (container) + offset_in_container,
2822 value_bitpos (container) + bit_offset_in_container,
2823 value_contents (val),
2824 TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2825 bits, 1);
2826 else
2827 move_bits (value_contents_writeable (container) + offset_in_container,
2828 value_bitpos (container) + bit_offset_in_container,
2829 value_contents (val), 0, bits, 0);
2830 }
2831
2832 /* The value of the element of array ARR at the ARITY indices given in IND.
2833 ARR may be either a simple array, GNAT array descriptor, or pointer
2834 thereto. */
2835
2836 struct value *
2837 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2838 {
2839 int k;
2840 struct value *elt;
2841 struct type *elt_type;
2842
2843 elt = ada_coerce_to_simple_array (arr);
2844
2845 elt_type = ada_check_typedef (value_type (elt));
2846 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2847 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2848 return value_subscript_packed (elt, arity, ind);
2849
2850 for (k = 0; k < arity; k += 1)
2851 {
2852 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2853 error (_("too many subscripts (%d expected)"), k);
2854 elt = value_subscript (elt, pos_atr (ind[k]));
2855 }
2856 return elt;
2857 }
2858
2859 /* Assuming ARR is a pointer to a GDB array, the value of the element
2860 of *ARR at the ARITY indices given in IND.
2861 Does not read the entire array into memory.
2862
2863 Note: Unlike what one would expect, this function is used instead of
2864 ada_value_subscript for basically all non-packed array types. The reason
2865 for this is that a side effect of doing our own pointer arithmetics instead
2866 of relying on value_subscript is that there is no implicit typedef peeling.
2867 This is important for arrays of array accesses, where it allows us to
2868 preserve the fact that the array's element is an array access, where the
2869 access part os encoded in a typedef layer. */
2870
2871 static struct value *
2872 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2873 {
2874 int k;
2875 struct value *array_ind = ada_value_ind (arr);
2876 struct type *type
2877 = check_typedef (value_enclosing_type (array_ind));
2878
2879 if (TYPE_CODE (type) == TYPE_CODE_ARRAY
2880 && TYPE_FIELD_BITSIZE (type, 0) > 0)
2881 return value_subscript_packed (array_ind, arity, ind);
2882
2883 for (k = 0; k < arity; k += 1)
2884 {
2885 LONGEST lwb, upb;
2886 struct value *lwb_value;
2887
2888 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2889 error (_("too many subscripts (%d expected)"), k);
2890 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
2891 value_copy (arr));
2892 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2893 lwb_value = value_from_longest (value_type(ind[k]), lwb);
2894 arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
2895 type = TYPE_TARGET_TYPE (type);
2896 }
2897
2898 return value_ind (arr);
2899 }
2900
2901 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2902 actual type of ARRAY_PTR is ignored), returns the Ada slice of
2903 HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2904 this array is LOW, as per Ada rules. */
2905 static struct value *
2906 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2907 int low, int high)
2908 {
2909 struct type *type0 = ada_check_typedef (type);
2910 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
2911 struct type *index_type
2912 = create_static_range_type (NULL, base_index_type, low, high);
2913 struct type *slice_type = create_array_type_with_stride
2914 (NULL, TYPE_TARGET_TYPE (type0), index_type,
2915 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type0),
2916 TYPE_FIELD_BITSIZE (type0, 0));
2917 int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2918 LONGEST base_low_pos, low_pos;
2919 CORE_ADDR base;
2920
2921 if (!discrete_position (base_index_type, low, &low_pos)
2922 || !discrete_position (base_index_type, base_low, &base_low_pos))
2923 {
2924 warning (_("unable to get positions in slice, use bounds instead"));
2925 low_pos = low;
2926 base_low_pos = base_low;
2927 }
2928
2929 base = value_as_address (array_ptr)
2930 + ((low_pos - base_low_pos)
2931 * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2932 return value_at_lazy (slice_type, base);
2933 }
2934
2935
2936 static struct value *
2937 ada_value_slice (struct value *array, int low, int high)
2938 {
2939 struct type *type = ada_check_typedef (value_type (array));
2940 struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2941 struct type *index_type
2942 = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2943 struct type *slice_type = create_array_type_with_stride
2944 (NULL, TYPE_TARGET_TYPE (type), index_type,
2945 get_dyn_prop (DYN_PROP_BYTE_STRIDE, type),
2946 TYPE_FIELD_BITSIZE (type, 0));
2947 LONGEST low_pos, high_pos;
2948
2949 if (!discrete_position (base_index_type, low, &low_pos)
2950 || !discrete_position (base_index_type, high, &high_pos))
2951 {
2952 warning (_("unable to get positions in slice, use bounds instead"));
2953 low_pos = low;
2954 high_pos = high;
2955 }
2956
2957 return value_cast (slice_type,
2958 value_slice (array, low, high_pos - low_pos + 1));
2959 }
2960
2961 /* If type is a record type in the form of a standard GNAT array
2962 descriptor, returns the number of dimensions for type. If arr is a
2963 simple array, returns the number of "array of"s that prefix its
2964 type designation. Otherwise, returns 0. */
2965
2966 int
2967 ada_array_arity (struct type *type)
2968 {
2969 int arity;
2970
2971 if (type == NULL)
2972 return 0;
2973
2974 type = desc_base_type (type);
2975
2976 arity = 0;
2977 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2978 return desc_arity (desc_bounds_type (type));
2979 else
2980 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2981 {
2982 arity += 1;
2983 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2984 }
2985
2986 return arity;
2987 }
2988
2989 /* If TYPE is a record type in the form of a standard GNAT array
2990 descriptor or a simple array type, returns the element type for
2991 TYPE after indexing by NINDICES indices, or by all indices if
2992 NINDICES is -1. Otherwise, returns NULL. */
2993
2994 struct type *
2995 ada_array_element_type (struct type *type, int nindices)
2996 {
2997 type = desc_base_type (type);
2998
2999 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
3000 {
3001 int k;
3002 struct type *p_array_type;
3003
3004 p_array_type = desc_data_target_type (type);
3005
3006 k = ada_array_arity (type);
3007 if (k == 0)
3008 return NULL;
3009
3010 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
3011 if (nindices >= 0 && k > nindices)
3012 k = nindices;
3013 while (k > 0 && p_array_type != NULL)
3014 {
3015 p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
3016 k -= 1;
3017 }
3018 return p_array_type;
3019 }
3020 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
3021 {
3022 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
3023 {
3024 type = TYPE_TARGET_TYPE (type);
3025 nindices -= 1;
3026 }
3027 return type;
3028 }
3029
3030 return NULL;
3031 }
3032
3033 /* The type of nth index in arrays of given type (n numbering from 1).
3034 Does not examine memory. Throws an error if N is invalid or TYPE
3035 is not an array type. NAME is the name of the Ada attribute being
3036 evaluated ('range, 'first, 'last, or 'length); it is used in building
3037 the error message. */
3038
3039 static struct type *
3040 ada_index_type (struct type *type, int n, const char *name)
3041 {
3042 struct type *result_type;
3043
3044 type = desc_base_type (type);
3045
3046 if (n < 0 || n > ada_array_arity (type))
3047 error (_("invalid dimension number to '%s"), name);
3048
3049 if (ada_is_simple_array_type (type))
3050 {
3051 int i;
3052
3053 for (i = 1; i < n; i += 1)
3054 type = TYPE_TARGET_TYPE (type);
3055 result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
3056 /* FIXME: The stabs type r(0,0);bound;bound in an array type
3057 has a target type of TYPE_CODE_UNDEF. We compensate here, but
3058 perhaps stabsread.c would make more sense. */
3059 if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
3060 result_type = NULL;
3061 }
3062 else
3063 {
3064 result_type = desc_index_type (desc_bounds_type (type), n);
3065 if (result_type == NULL)
3066 error (_("attempt to take bound of something that is not an array"));
3067 }
3068
3069 return result_type;
3070 }
3071
3072 /* Given that arr is an array type, returns the lower bound of the
3073 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
3074 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
3075 array-descriptor type. It works for other arrays with bounds supplied
3076 by run-time quantities other than discriminants. */
3077
3078 static LONGEST
3079 ada_array_bound_from_type (struct type *arr_type, int n, int which)
3080 {
3081 struct type *type, *index_type_desc, *index_type;
3082 int i;
3083
3084 gdb_assert (which == 0 || which == 1);
3085
3086 if (ada_is_constrained_packed_array_type (arr_type))
3087 arr_type = decode_constrained_packed_array_type (arr_type);
3088
3089 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
3090 return (LONGEST) - which;
3091
3092 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
3093 type = TYPE_TARGET_TYPE (arr_type);
3094 else
3095 type = arr_type;
3096
3097 if (TYPE_FIXED_INSTANCE (type))
3098 {
3099 /* The array has already been fixed, so we do not need to
3100 check the parallel ___XA type again. That encoding has
3101 already been applied, so ignore it now. */
3102 index_type_desc = NULL;
3103 }
3104 else
3105 {
3106 index_type_desc = ada_find_parallel_type (type, "___XA");
3107 ada_fixup_array_indexes_type (index_type_desc);
3108 }
3109
3110 if (index_type_desc != NULL)
3111 index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
3112 NULL);
3113 else
3114 {
3115 struct type *elt_type = check_typedef (type);
3116
3117 for (i = 1; i < n; i++)
3118 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
3119
3120 index_type = TYPE_INDEX_TYPE (elt_type);
3121 }
3122
3123 return
3124 (LONGEST) (which == 0
3125 ? ada_discrete_type_low_bound (index_type)
3126 : ada_discrete_type_high_bound (index_type));
3127 }
3128
3129 /* Given that arr is an array value, returns the lower bound of the
3130 nth index (numbering from 1) if WHICH is 0, and the upper bound if
3131 WHICH is 1. This routine will also work for arrays with bounds
3132 supplied by run-time quantities other than discriminants. */
3133
3134 static LONGEST
3135 ada_array_bound (struct value *arr, int n, int which)
3136 {
3137 struct type *arr_type;
3138
3139 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3140 arr = value_ind (arr);
3141 arr_type = value_enclosing_type (arr);
3142
3143 if (ada_is_constrained_packed_array_type (arr_type))
3144 return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3145 else if (ada_is_simple_array_type (arr_type))
3146 return ada_array_bound_from_type (arr_type, n, which);
3147 else
3148 return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3149 }
3150
3151 /* Given that arr is an array value, returns the length of the
3152 nth index. This routine will also work for arrays with bounds
3153 supplied by run-time quantities other than discriminants.
3154 Does not work for arrays indexed by enumeration types with representation
3155 clauses at the moment. */
3156
3157 static LONGEST
3158 ada_array_length (struct value *arr, int n)
3159 {
3160 struct type *arr_type, *index_type;
3161 int low, high;
3162
3163 if (TYPE_CODE (check_typedef (value_type (arr))) == TYPE_CODE_PTR)
3164 arr = value_ind (arr);
3165 arr_type = value_enclosing_type (arr);
3166
3167 if (ada_is_constrained_packed_array_type (arr_type))
3168 return ada_array_length (decode_constrained_packed_array (arr), n);
3169
3170 if (ada_is_simple_array_type (arr_type))
3171 {
3172 low = ada_array_bound_from_type (arr_type, n, 0);
3173 high = ada_array_bound_from_type (arr_type, n, 1);
3174 }
3175 else
3176 {
3177 low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3178 high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3179 }
3180
3181 arr_type = check_typedef (arr_type);
3182 index_type = TYPE_INDEX_TYPE (arr_type);
3183 if (index_type != NULL)
3184 {
3185 struct type *base_type;
3186 if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3187 base_type = TYPE_TARGET_TYPE (index_type);
3188 else
3189 base_type = index_type;
3190
3191 low = pos_atr (value_from_longest (base_type, low));
3192 high = pos_atr (value_from_longest (base_type, high));
3193 }
3194 return high - low + 1;
3195 }
3196
3197 /* An empty array whose type is that of ARR_TYPE (an array type),
3198 with bounds LOW to LOW-1. */
3199
3200 static struct value *
3201 empty_array (struct type *arr_type, int low)
3202 {
3203 struct type *arr_type0 = ada_check_typedef (arr_type);
3204 struct type *index_type
3205 = create_static_range_type
3206 (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
3207 struct type *elt_type = ada_array_element_type (arr_type0, 1);
3208
3209 return allocate_value (create_array_type (NULL, elt_type, index_type));
3210 }
3211
3212
3213 /* Name resolution */
3214
3215 /* The "decoded" name for the user-definable Ada operator corresponding
3216 to OP. */
3217
3218 static const char *
3219 ada_decoded_op_name (enum exp_opcode op)
3220 {
3221 int i;
3222
3223 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3224 {
3225 if (ada_opname_table[i].op == op)
3226 return ada_opname_table[i].decoded;
3227 }
3228 error (_("Could not find operator name for opcode"));
3229 }
3230
3231
3232 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3233 references (marked by OP_VAR_VALUE nodes in which the symbol has an
3234 undefined namespace) and converts operators that are
3235 user-defined into appropriate function calls. If CONTEXT_TYPE is
3236 non-null, it provides a preferred result type [at the moment, only
3237 type void has any effect---causing procedures to be preferred over
3238 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3239 return type is preferred. May change (expand) *EXP. */
3240
3241 static void
3242 resolve (expression_up *expp, int void_context_p)
3243 {
3244 struct type *context_type = NULL;
3245 int pc = 0;
3246
3247 if (void_context_p)
3248 context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3249
3250 resolve_subexp (expp, &pc, 1, context_type);
3251 }
3252
3253 /* Resolve the operator of the subexpression beginning at
3254 position *POS of *EXPP. "Resolving" consists of replacing
3255 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3256 with their resolutions, replacing built-in operators with
3257 function calls to user-defined operators, where appropriate, and,
3258 when DEPROCEDURE_P is non-zero, converting function-valued variables
3259 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3260 are as in ada_resolve, above. */
3261
3262 static struct value *
3263 resolve_subexp (expression_up *expp, int *pos, int deprocedure_p,
3264 struct type *context_type)
3265 {
3266 int pc = *pos;
3267 int i;
3268 struct expression *exp; /* Convenience: == *expp. */
3269 enum exp_opcode op = (*expp)->elts[pc].opcode;
3270 struct value **argvec; /* Vector of operand types (alloca'ed). */
3271 int nargs; /* Number of operands. */
3272 int oplen;
3273 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
3274
3275 argvec = NULL;
3276 nargs = 0;
3277 exp = expp->get ();
3278
3279 /* Pass one: resolve operands, saving their types and updating *pos,
3280 if needed. */
3281 switch (op)
3282 {
3283 case OP_FUNCALL:
3284 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3285 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3286 *pos += 7;
3287 else
3288 {
3289 *pos += 3;
3290 resolve_subexp (expp, pos, 0, NULL);
3291 }
3292 nargs = longest_to_int (exp->elts[pc + 1].longconst);
3293 break;
3294
3295 case UNOP_ADDR:
3296 *pos += 1;
3297 resolve_subexp (expp, pos, 0, NULL);
3298 break;
3299
3300 case UNOP_QUAL:
3301 *pos += 3;
3302 resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
3303 break;
3304
3305 case OP_ATR_MODULUS:
3306 case OP_ATR_SIZE:
3307 case OP_ATR_TAG:
3308 case OP_ATR_FIRST:
3309 case OP_ATR_LAST:
3310 case OP_ATR_LENGTH:
3311 case OP_ATR_POS:
3312 case OP_ATR_VAL:
3313 case OP_ATR_MIN:
3314 case OP_ATR_MAX:
3315 case TERNOP_IN_RANGE:
3316 case BINOP_IN_BOUNDS:
3317 case UNOP_IN_RANGE:
3318 case OP_AGGREGATE:
3319 case OP_OTHERS:
3320 case OP_CHOICES:
3321 case OP_POSITIONAL:
3322 case OP_DISCRETE_RANGE:
3323 case OP_NAME:
3324 ada_forward_operator_length (exp, pc, &oplen, &nargs);
3325 *pos += oplen;
3326 break;
3327
3328 case BINOP_ASSIGN:
3329 {
3330 struct value *arg1;
3331
3332 *pos += 1;
3333 arg1 = resolve_subexp (expp, pos, 0, NULL);
3334 if (arg1 == NULL)
3335 resolve_subexp (expp, pos, 1, NULL);
3336 else
3337 resolve_subexp (expp, pos, 1, value_type (arg1));
3338 break;
3339 }
3340
3341 case UNOP_CAST:
3342 *pos += 3;
3343 nargs = 1;
3344 break;
3345
3346 case BINOP_ADD:
3347 case BINOP_SUB:
3348 case BINOP_MUL:
3349 case BINOP_DIV:
3350 case BINOP_REM:
3351 case BINOP_MOD:
3352 case BINOP_EXP:
3353 case BINOP_CONCAT:
3354 case BINOP_LOGICAL_AND:
3355 case BINOP_LOGICAL_OR:
3356 case BINOP_BITWISE_AND:
3357 case BINOP_BITWISE_IOR:
3358 case BINOP_BITWISE_XOR:
3359
3360 case BINOP_EQUAL:
3361 case BINOP_NOTEQUAL:
3362 case BINOP_LESS:
3363 case BINOP_GTR:
3364 case BINOP_LEQ:
3365 case BINOP_GEQ:
3366
3367 case BINOP_REPEAT:
3368 case BINOP_SUBSCRIPT:
3369 case BINOP_COMMA:
3370 *pos += 1;
3371 nargs = 2;
3372 break;
3373
3374 case UNOP_NEG:
3375 case UNOP_PLUS:
3376 case UNOP_LOGICAL_NOT:
3377 case UNOP_ABS:
3378 case UNOP_IND:
3379 *pos += 1;
3380 nargs = 1;
3381 break;
3382
3383 case OP_LONG:
3384 case OP_FLOAT:
3385 case OP_VAR_VALUE:
3386 case OP_VAR_MSYM_VALUE:
3387 *pos += 4;
3388 break;
3389
3390 case OP_TYPE:
3391 case OP_BOOL:
3392 case OP_LAST:
3393 case OP_INTERNALVAR:
3394 *pos += 3;
3395 break;
3396
3397 case UNOP_MEMVAL:
3398 *pos += 3;
3399 nargs = 1;
3400 break;
3401
3402 case OP_REGISTER:
3403 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3404 break;
3405
3406 case STRUCTOP_STRUCT:
3407 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3408 nargs = 1;
3409 break;
3410
3411 case TERNOP_SLICE:
3412 *pos += 1;
3413 nargs = 3;
3414 break;
3415
3416 case OP_STRING:
3417 break;
3418
3419 default:
3420 error (_("Unexpected operator during name resolution"));
3421 }
3422
3423 argvec = XALLOCAVEC (struct value *, nargs + 1);
3424 for (i = 0; i < nargs; i += 1)
3425 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3426 argvec[i] = NULL;
3427 exp = expp->get ();
3428
3429 /* Pass two: perform any resolution on principal operator. */
3430 switch (op)
3431 {
3432 default:
3433 break;
3434
3435 case OP_VAR_VALUE:
3436 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3437 {
3438 struct block_symbol *candidates;
3439 int n_candidates;
3440
3441 n_candidates =
3442 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3443 (exp->elts[pc + 2].symbol),
3444 exp->elts[pc + 1].block, VAR_DOMAIN,
3445 &candidates);
3446 make_cleanup (xfree, candidates);
3447
3448 if (n_candidates > 1)
3449 {
3450 /* Types tend to get re-introduced locally, so if there
3451 are any local symbols that are not types, first filter
3452 out all types. */
3453 int j;
3454 for (j = 0; j < n_candidates; j += 1)
3455 switch (SYMBOL_CLASS (candidates[j].symbol))
3456 {
3457 case LOC_REGISTER:
3458 case LOC_ARG:
3459 case LOC_REF_ARG:
3460 case LOC_REGPARM_ADDR:
3461 case LOC_LOCAL:
3462 case LOC_COMPUTED:
3463 goto FoundNonType;
3464 default:
3465 break;
3466 }
3467 FoundNonType:
3468 if (j < n_candidates)
3469 {
3470 j = 0;
3471 while (j < n_candidates)
3472 {
3473 if (SYMBOL_CLASS (candidates[j].symbol) == LOC_TYPEDEF)
3474 {
3475 candidates[j] = candidates[n_candidates - 1];
3476 n_candidates -= 1;
3477 }
3478 else
3479 j += 1;
3480 }
3481 }
3482 }
3483
3484 if (n_candidates == 0)
3485 error (_("No definition found for %s"),
3486 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3487 else if (n_candidates == 1)
3488 i = 0;
3489 else if (deprocedure_p
3490 && !is_nonfunction (candidates, n_candidates))
3491 {
3492 i = ada_resolve_function
3493 (candidates, n_candidates, NULL, 0,
3494 SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3495 context_type);
3496 if (i < 0)
3497 error (_("Could not find a match for %s"),
3498 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3499 }
3500 else
3501 {
3502 printf_filtered (_("Multiple matches for %s\n"),
3503 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3504 user_select_syms (candidates, n_candidates, 1);
3505 i = 0;
3506 }
3507
3508 exp->elts[pc + 1].block = candidates[i].block;
3509 exp->elts[pc + 2].symbol = candidates[i].symbol;
3510 if (innermost_block == NULL
3511 || contained_in (candidates[i].block, innermost_block))
3512 innermost_block = candidates[i].block;
3513 }
3514
3515 if (deprocedure_p
3516 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3517 == TYPE_CODE_FUNC))
3518 {
3519 replace_operator_with_call (expp, pc, 0, 0,
3520 exp->elts[pc + 2].symbol,
3521 exp->elts[pc + 1].block);
3522 exp = expp->get ();
3523 }
3524 break;
3525
3526 case OP_FUNCALL:
3527 {
3528 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3529 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3530 {
3531 struct block_symbol *candidates;
3532 int n_candidates;
3533
3534 n_candidates =
3535 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
3536 (exp->elts[pc + 5].symbol),
3537 exp->elts[pc + 4].block, VAR_DOMAIN,
3538 &candidates);
3539 make_cleanup (xfree, candidates);
3540
3541 if (n_candidates == 1)
3542 i = 0;
3543 else
3544 {
3545 i = ada_resolve_function
3546 (candidates, n_candidates,
3547 argvec, nargs,
3548 SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3549 context_type);
3550 if (i < 0)
3551 error (_("Could not find a match for %s"),
3552 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3553 }
3554
3555 exp->elts[pc + 4].block = candidates[i].block;
3556 exp->elts[pc + 5].symbol = candidates[i].symbol;
3557 if (innermost_block == NULL
3558 || contained_in (candidates[i].block, innermost_block))
3559 innermost_block = candidates[i].block;
3560 }
3561 }
3562 break;
3563 case BINOP_ADD:
3564 case BINOP_SUB:
3565 case BINOP_MUL:
3566 case BINOP_DIV:
3567 case BINOP_REM:
3568 case BINOP_MOD:
3569 case BINOP_CONCAT:
3570 case BINOP_BITWISE_AND:
3571 case BINOP_BITWISE_IOR:
3572 case BINOP_BITWISE_XOR:
3573 case BINOP_EQUAL:
3574 case BINOP_NOTEQUAL:
3575 case BINOP_LESS:
3576 case BINOP_GTR:
3577 case BINOP_LEQ:
3578 case BINOP_GEQ:
3579 case BINOP_EXP:
3580 case UNOP_NEG:
3581 case UNOP_PLUS:
3582 case UNOP_LOGICAL_NOT:
3583 case UNOP_ABS:
3584 if (possible_user_operator_p (op, argvec))
3585 {
3586 struct block_symbol *candidates;
3587 int n_candidates;
3588
3589 n_candidates =
3590 ada_lookup_symbol_list (ada_decoded_op_name (op),
3591 (struct block *) NULL, VAR_DOMAIN,
3592 &candidates);
3593 make_cleanup (xfree, candidates);
3594
3595 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3596 ada_decoded_op_name (op), NULL);
3597 if (i < 0)
3598 break;
3599
3600 replace_operator_with_call (expp, pc, nargs, 1,
3601 candidates[i].symbol,
3602 candidates[i].block);
3603 exp = expp->get ();
3604 }
3605 break;
3606
3607 case OP_TYPE:
3608 case OP_REGISTER:
3609 do_cleanups (old_chain);
3610 return NULL;
3611 }
3612
3613 *pos = pc;
3614 do_cleanups (old_chain);
3615 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
3616 return evaluate_var_msym_value (EVAL_AVOID_SIDE_EFFECTS,
3617 exp->elts[pc + 1].objfile,
3618 exp->elts[pc + 2].msymbol);
3619 else
3620 return evaluate_subexp_type (exp, pos);
3621 }
3622
3623 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3624 MAY_DEREF is non-zero, the formal may be a pointer and the actual
3625 a non-pointer. */
3626 /* The term "match" here is rather loose. The match is heuristic and
3627 liberal. */
3628
3629 static int
3630 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3631 {
3632 ftype = ada_check_typedef (ftype);
3633 atype = ada_check_typedef (atype);
3634
3635 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3636 ftype = TYPE_TARGET_TYPE (ftype);
3637 if (TYPE_CODE (atype) == TYPE_CODE_REF)
3638 atype = TYPE_TARGET_TYPE (atype);
3639
3640 switch (TYPE_CODE (ftype))
3641 {
3642 default:
3643 return TYPE_CODE (ftype) == TYPE_CODE (atype);
3644 case TYPE_CODE_PTR:
3645 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3646 return ada_type_match (TYPE_TARGET_TYPE (ftype),
3647 TYPE_TARGET_TYPE (atype), 0);
3648 else
3649 return (may_deref
3650 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3651 case TYPE_CODE_INT:
3652 case TYPE_CODE_ENUM:
3653 case TYPE_CODE_RANGE:
3654 switch (TYPE_CODE (atype))
3655 {
3656 case TYPE_CODE_INT:
3657 case TYPE_CODE_ENUM:
3658 case TYPE_CODE_RANGE:
3659 return 1;
3660 default:
3661 return 0;
3662 }
3663
3664 case TYPE_CODE_ARRAY:
3665 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3666 || ada_is_array_descriptor_type (atype));
3667
3668 case TYPE_CODE_STRUCT:
3669 if (ada_is_array_descriptor_type (ftype))
3670 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3671 || ada_is_array_descriptor_type (atype));
3672 else
3673 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3674 && !ada_is_array_descriptor_type (atype));
3675
3676 case TYPE_CODE_UNION:
3677 case TYPE_CODE_FLT:
3678 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3679 }
3680 }
3681
3682 /* Return non-zero if the formals of FUNC "sufficiently match" the
3683 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3684 may also be an enumeral, in which case it is treated as a 0-
3685 argument function. */
3686
3687 static int
3688 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3689 {
3690 int i;
3691 struct type *func_type = SYMBOL_TYPE (func);
3692
3693 if (SYMBOL_CLASS (func) == LOC_CONST
3694 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3695 return (n_actuals == 0);
3696 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3697 return 0;
3698
3699 if (TYPE_NFIELDS (func_type) != n_actuals)
3700 return 0;
3701
3702 for (i = 0; i < n_actuals; i += 1)
3703 {
3704 if (actuals[i] == NULL)
3705 return 0;
3706 else
3707 {
3708 struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3709 i));
3710 struct type *atype = ada_check_typedef (value_type (actuals[i]));
3711
3712 if (!ada_type_match (ftype, atype, 1))
3713 return 0;
3714 }
3715 }
3716 return 1;
3717 }
3718
3719 /* False iff function type FUNC_TYPE definitely does not produce a value
3720 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3721 FUNC_TYPE is not a valid function type with a non-null return type
3722 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3723
3724 static int
3725 return_match (struct type *func_type, struct type *context_type)
3726 {
3727 struct type *return_type;
3728
3729 if (func_type == NULL)
3730 return 1;
3731
3732 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3733 return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3734 else
3735 return_type = get_base_type (func_type);
3736 if (return_type == NULL)
3737 return 1;
3738
3739 context_type = get_base_type (context_type);
3740
3741 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3742 return context_type == NULL || return_type == context_type;
3743 else if (context_type == NULL)
3744 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3745 else
3746 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3747 }
3748
3749
3750 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3751 function (if any) that matches the types of the NARGS arguments in
3752 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3753 that returns that type, then eliminate matches that don't. If
3754 CONTEXT_TYPE is void and there is at least one match that does not
3755 return void, eliminate all matches that do.
3756
3757 Asks the user if there is more than one match remaining. Returns -1
3758 if there is no such symbol or none is selected. NAME is used
3759 solely for messages. May re-arrange and modify SYMS in
3760 the process; the index returned is for the modified vector. */
3761
3762 static int
3763 ada_resolve_function (struct block_symbol syms[],
3764 int nsyms, struct value **args, int nargs,
3765 const char *name, struct type *context_type)
3766 {
3767 int fallback;
3768 int k;
3769 int m; /* Number of hits */
3770
3771 m = 0;
3772 /* In the first pass of the loop, we only accept functions matching
3773 context_type. If none are found, we add a second pass of the loop
3774 where every function is accepted. */
3775 for (fallback = 0; m == 0 && fallback < 2; fallback++)
3776 {
3777 for (k = 0; k < nsyms; k += 1)
3778 {
3779 struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].symbol));
3780
3781 if (ada_args_match (syms[k].symbol, args, nargs)
3782 && (fallback || return_match (type, context_type)))
3783 {
3784 syms[m] = syms[k];
3785 m += 1;
3786 }
3787 }
3788 }
3789
3790 /* If we got multiple matches, ask the user which one to use. Don't do this
3791 interactive thing during completion, though, as the purpose of the
3792 completion is providing a list of all possible matches. Prompting the
3793 user to filter it down would be completely unexpected in this case. */
3794 if (m == 0)
3795 return -1;
3796 else if (m > 1 && !parse_completion)
3797 {
3798 printf_filtered (_("Multiple matches for %s\n"), name);
3799 user_select_syms (syms, m, 1);
3800 return 0;
3801 }
3802 return 0;
3803 }
3804
3805 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3806 in a listing of choices during disambiguation (see sort_choices, below).
3807 The idea is that overloadings of a subprogram name from the
3808 same package should sort in their source order. We settle for ordering
3809 such symbols by their trailing number (__N or $N). */
3810
3811 static int
3812 encoded_ordered_before (const char *N0, const char *N1)
3813 {
3814 if (N1 == NULL)
3815 return 0;
3816 else if (N0 == NULL)
3817 return 1;
3818 else
3819 {
3820 int k0, k1;
3821
3822 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3823 ;
3824 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3825 ;
3826 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3827 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3828 {
3829 int n0, n1;
3830
3831 n0 = k0;
3832 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3833 n0 -= 1;
3834 n1 = k1;
3835 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3836 n1 -= 1;
3837 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3838 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3839 }
3840 return (strcmp (N0, N1) < 0);
3841 }
3842 }
3843
3844 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3845 encoded names. */
3846
3847 static void
3848 sort_choices (struct block_symbol syms[], int nsyms)
3849 {
3850 int i;
3851
3852 for (i = 1; i < nsyms; i += 1)
3853 {
3854 struct block_symbol sym = syms[i];
3855 int j;
3856
3857 for (j = i - 1; j >= 0; j -= 1)
3858 {
3859 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].symbol),
3860 SYMBOL_LINKAGE_NAME (sym.symbol)))
3861 break;
3862 syms[j + 1] = syms[j];
3863 }
3864 syms[j + 1] = sym;
3865 }
3866 }
3867
3868 /* Whether GDB should display formals and return types for functions in the
3869 overloads selection menu. */
3870 static int print_signatures = 1;
3871
3872 /* Print the signature for SYM on STREAM according to the FLAGS options. For
3873 all but functions, the signature is just the name of the symbol. For
3874 functions, this is the name of the function, the list of types for formals
3875 and the return type (if any). */
3876
3877 static void
3878 ada_print_symbol_signature (struct ui_file *stream, struct symbol *sym,
3879 const struct type_print_options *flags)
3880 {
3881 struct type *type = SYMBOL_TYPE (sym);
3882
3883 fprintf_filtered (stream, "%s", SYMBOL_PRINT_NAME (sym));
3884 if (!print_signatures
3885 || type == NULL
3886 || TYPE_CODE (type) != TYPE_CODE_FUNC)
3887 return;
3888
3889 if (TYPE_NFIELDS (type) > 0)
3890 {
3891 int i;
3892
3893 fprintf_filtered (stream, " (");
3894 for (i = 0; i < TYPE_NFIELDS (type); ++i)
3895 {
3896 if (i > 0)
3897 fprintf_filtered (stream, "; ");
3898 ada_print_type (TYPE_FIELD_TYPE (type, i), NULL, stream, -1, 0,
3899 flags);
3900 }
3901 fprintf_filtered (stream, ")");
3902 }
3903 if (TYPE_TARGET_TYPE (type) != NULL
3904 && TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
3905 {
3906 fprintf_filtered (stream, " return ");
3907 ada_print_type (TYPE_TARGET_TYPE (type), NULL, stream, -1, 0, flags);
3908 }
3909 }
3910
3911 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3912 by asking the user (if necessary), returning the number selected,
3913 and setting the first elements of SYMS items. Error if no symbols
3914 selected. */
3915
3916 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3917 to be re-integrated one of these days. */
3918
3919 int
3920 user_select_syms (struct block_symbol *syms, int nsyms, int max_results)
3921 {
3922 int i;
3923 int *chosen = XALLOCAVEC (int , nsyms);
3924 int n_chosen;
3925 int first_choice = (max_results == 1) ? 1 : 2;
3926 const char *select_mode = multiple_symbols_select_mode ();
3927
3928 if (max_results < 1)
3929 error (_("Request to select 0 symbols!"));
3930 if (nsyms <= 1)
3931 return nsyms;
3932
3933 if (select_mode == multiple_symbols_cancel)
3934 error (_("\
3935 canceled because the command is ambiguous\n\
3936 See set/show multiple-symbol."));
3937
3938 /* If select_mode is "all", then return all possible symbols.
3939 Only do that if more than one symbol can be selected, of course.
3940 Otherwise, display the menu as usual. */
3941 if (select_mode == multiple_symbols_all && max_results > 1)
3942 return nsyms;
3943
3944 printf_unfiltered (_("[0] cancel\n"));
3945 if (max_results > 1)
3946 printf_unfiltered (_("[1] all\n"));
3947
3948 sort_choices (syms, nsyms);
3949
3950 for (i = 0; i < nsyms; i += 1)
3951 {
3952 if (syms[i].symbol == NULL)
3953 continue;
3954
3955 if (SYMBOL_CLASS (syms[i].symbol) == LOC_BLOCK)
3956 {
3957 struct symtab_and_line sal =
3958 find_function_start_sal (syms[i].symbol, 1);
3959
3960 printf_unfiltered ("[%d] ", i + first_choice);
3961 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3962 &type_print_raw_options);
3963 if (sal.symtab == NULL)
3964 printf_unfiltered (_(" at <no source file available>:%d\n"),
3965 sal.line);
3966 else
3967 printf_unfiltered (_(" at %s:%d\n"),
3968 symtab_to_filename_for_display (sal.symtab),
3969 sal.line);
3970 continue;
3971 }
3972 else
3973 {
3974 int is_enumeral =
3975 (SYMBOL_CLASS (syms[i].symbol) == LOC_CONST
3976 && SYMBOL_TYPE (syms[i].symbol) != NULL
3977 && TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) == TYPE_CODE_ENUM);
3978 struct symtab *symtab = NULL;
3979
3980 if (SYMBOL_OBJFILE_OWNED (syms[i].symbol))
3981 symtab = symbol_symtab (syms[i].symbol);
3982
3983 if (SYMBOL_LINE (syms[i].symbol) != 0 && symtab != NULL)
3984 {
3985 printf_unfiltered ("[%d] ", i + first_choice);
3986 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
3987 &type_print_raw_options);
3988 printf_unfiltered (_(" at %s:%d\n"),
3989 symtab_to_filename_for_display (symtab),
3990 SYMBOL_LINE (syms[i].symbol));
3991 }
3992 else if (is_enumeral
3993 && TYPE_NAME (SYMBOL_TYPE (syms[i].symbol)) != NULL)
3994 {
3995 printf_unfiltered (("[%d] "), i + first_choice);
3996 ada_print_type (SYMBOL_TYPE (syms[i].symbol), NULL,
3997 gdb_stdout, -1, 0, &type_print_raw_options);
3998 printf_unfiltered (_("'(%s) (enumeral)\n"),
3999 SYMBOL_PRINT_NAME (syms[i].symbol));
4000 }
4001 else
4002 {
4003 printf_unfiltered ("[%d] ", i + first_choice);
4004 ada_print_symbol_signature (gdb_stdout, syms[i].symbol,
4005 &type_print_raw_options);
4006
4007 if (symtab != NULL)
4008 printf_unfiltered (is_enumeral
4009 ? _(" in %s (enumeral)\n")
4010 : _(" at %s:?\n"),
4011 symtab_to_filename_for_display (symtab));
4012 else
4013 printf_unfiltered (is_enumeral
4014 ? _(" (enumeral)\n")
4015 : _(" at ?\n"));
4016 }
4017 }
4018 }
4019
4020 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4021 "overload-choice");
4022
4023 for (i = 0; i < n_chosen; i += 1)
4024 syms[i] = syms[chosen[i]];
4025
4026 return n_chosen;
4027 }
4028
4029 /* Read and validate a set of numeric choices from the user in the
4030 range 0 .. N_CHOICES-1. Place the results in increasing
4031 order in CHOICES[0 .. N-1], and return N.
4032
4033 The user types choices as a sequence of numbers on one line
4034 separated by blanks, encoding them as follows:
4035
4036 + A choice of 0 means to cancel the selection, throwing an error.
4037 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
4038 + The user chooses k by typing k+IS_ALL_CHOICE+1.
4039
4040 The user is not allowed to choose more than MAX_RESULTS values.
4041
4042 ANNOTATION_SUFFIX, if present, is used to annotate the input
4043 prompts (for use with the -f switch). */
4044
4045 int
4046 get_selections (int *choices, int n_choices, int max_results,
4047 int is_all_choice, const char *annotation_suffix)
4048 {
4049 char *args;
4050 const char *prompt;
4051 int n_chosen;
4052 int first_choice = is_all_choice ? 2 : 1;
4053
4054 prompt = getenv ("PS2");
4055 if (prompt == NULL)
4056 prompt = "> ";
4057
4058 args = command_line_input (prompt, 0, annotation_suffix);
4059
4060 if (args == NULL)
4061 error_no_arg (_("one or more choice numbers"));
4062
4063 n_chosen = 0;
4064
4065 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
4066 order, as given in args. Choices are validated. */
4067 while (1)
4068 {
4069 char *args2;
4070 int choice, j;
4071
4072 args = skip_spaces (args);
4073 if (*args == '\0' && n_chosen == 0)
4074 error_no_arg (_("one or more choice numbers"));
4075 else if (*args == '\0')
4076 break;
4077
4078 choice = strtol (args, &args2, 10);
4079 if (args == args2 || choice < 0
4080 || choice > n_choices + first_choice - 1)
4081 error (_("Argument must be choice number"));
4082 args = args2;
4083
4084 if (choice == 0)
4085 error (_("cancelled"));
4086
4087 if (choice < first_choice)
4088 {
4089 n_chosen = n_choices;
4090 for (j = 0; j < n_choices; j += 1)
4091 choices[j] = j;
4092 break;
4093 }
4094 choice -= first_choice;
4095
4096 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4097 {
4098 }
4099
4100 if (j < 0 || choice != choices[j])
4101 {
4102 int k;
4103
4104 for (k = n_chosen - 1; k > j; k -= 1)
4105 choices[k + 1] = choices[k];
4106 choices[j + 1] = choice;
4107 n_chosen += 1;
4108 }
4109 }
4110
4111 if (n_chosen > max_results)
4112 error (_("Select no more than %d of the above"), max_results);
4113
4114 return n_chosen;
4115 }
4116
4117 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
4118 on the function identified by SYM and BLOCK, and taking NARGS
4119 arguments. Update *EXPP as needed to hold more space. */
4120
4121 static void
4122 replace_operator_with_call (expression_up *expp, int pc, int nargs,
4123 int oplen, struct symbol *sym,
4124 const struct block *block)
4125 {
4126 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4127 symbol, -oplen for operator being replaced). */
4128 struct expression *newexp = (struct expression *)
4129 xzalloc (sizeof (struct expression)
4130 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
4131 struct expression *exp = expp->get ();
4132
4133 newexp->nelts = exp->nelts + 7 - oplen;
4134 newexp->language_defn = exp->language_defn;
4135 newexp->gdbarch = exp->gdbarch;
4136 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
4137 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4138 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
4139
4140 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
4141 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
4142
4143 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
4144 newexp->elts[pc + 4].block = block;
4145 newexp->elts[pc + 5].symbol = sym;
4146
4147 expp->reset (newexp);
4148 }
4149
4150 /* Type-class predicates */
4151
4152 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
4153 or FLOAT). */
4154
4155 static int
4156 numeric_type_p (struct type *type)
4157 {
4158 if (type == NULL)
4159 return 0;
4160 else
4161 {
4162 switch (TYPE_CODE (type))
4163 {
4164 case TYPE_CODE_INT:
4165 case TYPE_CODE_FLT:
4166 return 1;
4167 case TYPE_CODE_RANGE:
4168 return (type == TYPE_TARGET_TYPE (type)
4169 || numeric_type_p (TYPE_TARGET_TYPE (type)));
4170 default:
4171 return 0;
4172 }
4173 }
4174 }
4175
4176 /* True iff TYPE is integral (an INT or RANGE of INTs). */
4177
4178 static int
4179 integer_type_p (struct type *type)
4180 {
4181 if (type == NULL)
4182 return 0;
4183 else
4184 {
4185 switch (TYPE_CODE (type))
4186 {
4187 case TYPE_CODE_INT:
4188 return 1;
4189 case TYPE_CODE_RANGE:
4190 return (type == TYPE_TARGET_TYPE (type)
4191 || integer_type_p (TYPE_TARGET_TYPE (type)));
4192 default:
4193 return 0;
4194 }
4195 }
4196 }
4197
4198 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4199
4200 static int
4201 scalar_type_p (struct type *type)
4202 {
4203 if (type == NULL)
4204 return 0;
4205 else
4206 {
4207 switch (TYPE_CODE (type))
4208 {
4209 case TYPE_CODE_INT:
4210 case TYPE_CODE_RANGE:
4211 case TYPE_CODE_ENUM:
4212 case TYPE_CODE_FLT:
4213 return 1;
4214 default:
4215 return 0;
4216 }
4217 }
4218 }
4219
4220 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4221
4222 static int
4223 discrete_type_p (struct type *type)
4224 {
4225 if (type == NULL)
4226 return 0;
4227 else
4228 {
4229 switch (TYPE_CODE (type))
4230 {
4231 case TYPE_CODE_INT:
4232 case TYPE_CODE_RANGE:
4233 case TYPE_CODE_ENUM:
4234 case TYPE_CODE_BOOL:
4235 return 1;
4236 default:
4237 return 0;
4238 }
4239 }
4240 }
4241
4242 /* Returns non-zero if OP with operands in the vector ARGS could be
4243 a user-defined function. Errs on the side of pre-defined operators
4244 (i.e., result 0). */
4245
4246 static int
4247 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4248 {
4249 struct type *type0 =
4250 (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4251 struct type *type1 =
4252 (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4253
4254 if (type0 == NULL)
4255 return 0;
4256
4257 switch (op)
4258 {
4259 default:
4260 return 0;
4261
4262 case BINOP_ADD:
4263 case BINOP_SUB:
4264 case BINOP_MUL:
4265 case BINOP_DIV:
4266 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4267
4268 case BINOP_REM:
4269 case BINOP_MOD:
4270 case BINOP_BITWISE_AND:
4271 case BINOP_BITWISE_IOR:
4272 case BINOP_BITWISE_XOR:
4273 return (!(integer_type_p (type0) && integer_type_p (type1)));
4274
4275 case BINOP_EQUAL:
4276 case BINOP_NOTEQUAL:
4277 case BINOP_LESS:
4278 case BINOP_GTR:
4279 case BINOP_LEQ:
4280 case BINOP_GEQ:
4281 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4282
4283 case BINOP_CONCAT:
4284 return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4285
4286 case BINOP_EXP:
4287 return (!(numeric_type_p (type0) && integer_type_p (type1)));
4288
4289 case UNOP_NEG:
4290 case UNOP_PLUS:
4291 case UNOP_LOGICAL_NOT:
4292 case UNOP_ABS:
4293 return (!numeric_type_p (type0));
4294
4295 }
4296 }
4297
4298 /* Renaming */
4299
4300 /* NOTES:
4301
4302 1. In the following, we assume that a renaming type's name may
4303 have an ___XD suffix. It would be nice if this went away at some
4304 point.
4305 2. We handle both the (old) purely type-based representation of
4306 renamings and the (new) variable-based encoding. At some point,
4307 it is devoutly to be hoped that the former goes away
4308 (FIXME: hilfinger-2007-07-09).
4309 3. Subprogram renamings are not implemented, although the XRS
4310 suffix is recognized (FIXME: hilfinger-2007-07-09). */
4311
4312 /* If SYM encodes a renaming,
4313
4314 <renaming> renames <renamed entity>,
4315
4316 sets *LEN to the length of the renamed entity's name,
4317 *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4318 the string describing the subcomponent selected from the renamed
4319 entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4320 (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4321 are undefined). Otherwise, returns a value indicating the category
4322 of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4323 (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4324 subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4325 strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4326 deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4327 may be NULL, in which case they are not assigned.
4328
4329 [Currently, however, GCC does not generate subprogram renamings.] */
4330
4331 enum ada_renaming_category
4332 ada_parse_renaming (struct symbol *sym,
4333 const char **renamed_entity, int *len,
4334 const char **renaming_expr)
4335 {
4336 enum ada_renaming_category kind;
4337 const char *info;
4338 const char *suffix;
4339
4340 if (sym == NULL)
4341 return ADA_NOT_RENAMING;
4342 switch (SYMBOL_CLASS (sym))
4343 {
4344 default:
4345 return ADA_NOT_RENAMING;
4346 case LOC_TYPEDEF:
4347 return parse_old_style_renaming (SYMBOL_TYPE (sym),
4348 renamed_entity, len, renaming_expr);
4349 case LOC_LOCAL:
4350 case LOC_STATIC:
4351 case LOC_COMPUTED:
4352 case LOC_OPTIMIZED_OUT:
4353 info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4354 if (info == NULL)
4355 return ADA_NOT_RENAMING;
4356 switch (info[5])
4357 {
4358 case '_':
4359 kind = ADA_OBJECT_RENAMING;
4360 info += 6;
4361 break;
4362 case 'E':
4363 kind = ADA_EXCEPTION_RENAMING;
4364 info += 7;
4365 break;
4366 case 'P':
4367 kind = ADA_PACKAGE_RENAMING;
4368 info += 7;
4369 break;
4370 case 'S':
4371 kind = ADA_SUBPROGRAM_RENAMING;
4372 info += 7;
4373 break;
4374 default:
4375 return ADA_NOT_RENAMING;
4376 }
4377 }
4378
4379 if (renamed_entity != NULL)
4380 *renamed_entity = info;
4381 suffix = strstr (info, "___XE");
4382 if (suffix == NULL || suffix == info)
4383 return ADA_NOT_RENAMING;
4384 if (len != NULL)
4385 *len = strlen (info) - strlen (suffix);
4386 suffix += 5;
4387 if (renaming_expr != NULL)
4388 *renaming_expr = suffix;
4389 return kind;
4390 }
4391
4392 /* Assuming TYPE encodes a renaming according to the old encoding in
4393 exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4394 *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4395 ADA_NOT_RENAMING otherwise. */
4396 static enum ada_renaming_category
4397 parse_old_style_renaming (struct type *type,
4398 const char **renamed_entity, int *len,
4399 const char **renaming_expr)
4400 {
4401 enum ada_renaming_category kind;
4402 const char *name;
4403 const char *info;
4404 const char *suffix;
4405
4406 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4407 || TYPE_NFIELDS (type) != 1)
4408 return ADA_NOT_RENAMING;
4409
4410 name = type_name_no_tag (type);
4411 if (name == NULL)
4412 return ADA_NOT_RENAMING;
4413
4414 name = strstr (name, "___XR");
4415 if (name == NULL)
4416 return ADA_NOT_RENAMING;
4417 switch (name[5])
4418 {
4419 case '\0':
4420 case '_':
4421 kind = ADA_OBJECT_RENAMING;
4422 break;
4423 case 'E':
4424 kind = ADA_EXCEPTION_RENAMING;
4425 break;
4426 case 'P':
4427 kind = ADA_PACKAGE_RENAMING;
4428 break;
4429 case 'S':
4430 kind = ADA_SUBPROGRAM_RENAMING;
4431 break;
4432 default:
4433 return ADA_NOT_RENAMING;
4434 }
4435
4436 info = TYPE_FIELD_NAME (type, 0);
4437 if (info == NULL)
4438 return ADA_NOT_RENAMING;
4439 if (renamed_entity != NULL)
4440 *renamed_entity = info;
4441 suffix = strstr (info, "___XE");
4442 if (renaming_expr != NULL)
4443 *renaming_expr = suffix + 5;
4444 if (suffix == NULL || suffix == info)
4445 return ADA_NOT_RENAMING;
4446 if (len != NULL)
4447 *len = suffix - info;
4448 return kind;
4449 }
4450
4451 /* Compute the value of the given RENAMING_SYM, which is expected to
4452 be a symbol encoding a renaming expression. BLOCK is the block
4453 used to evaluate the renaming. */
4454
4455 static struct value *
4456 ada_read_renaming_var_value (struct symbol *renaming_sym,
4457 const struct block *block)
4458 {
4459 const char *sym_name;
4460
4461 sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4462 expression_up expr = parse_exp_1 (&sym_name, 0, block, 0);
4463 return evaluate_expression (expr.get ());
4464 }
4465
4466
4467 /* Evaluation: Function Calls */
4468
4469 /* Return an lvalue containing the value VAL. This is the identity on
4470 lvalues, and otherwise has the side-effect of allocating memory
4471 in the inferior where a copy of the value contents is copied. */
4472
4473 static struct value *
4474 ensure_lval (struct value *val)
4475 {
4476 if (VALUE_LVAL (val) == not_lval
4477 || VALUE_LVAL (val) == lval_internalvar)
4478 {
4479 int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4480 const CORE_ADDR addr =
4481 value_as_long (value_allocate_space_in_inferior (len));
4482
4483 VALUE_LVAL (val) = lval_memory;
4484 set_value_address (val, addr);
4485 write_memory (addr, value_contents (val), len);
4486 }
4487
4488 return val;
4489 }
4490
4491 /* Return the value ACTUAL, converted to be an appropriate value for a
4492 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4493 allocating any necessary descriptors (fat pointers), or copies of
4494 values not residing in memory, updating it as needed. */
4495
4496 struct value *
4497 ada_convert_actual (struct value *actual, struct type *formal_type0)
4498 {
4499 struct type *actual_type = ada_check_typedef (value_type (actual));
4500 struct type *formal_type = ada_check_typedef (formal_type0);
4501 struct type *formal_target =
4502 TYPE_CODE (formal_type) == TYPE_CODE_PTR
4503 ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4504 struct type *actual_target =
4505 TYPE_CODE (actual_type) == TYPE_CODE_PTR
4506 ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4507
4508 if (ada_is_array_descriptor_type (formal_target)
4509 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4510 return make_array_descriptor (formal_type, actual);
4511 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4512 || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4513 {
4514 struct value *result;
4515
4516 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4517 && ada_is_array_descriptor_type (actual_target))
4518 result = desc_data (actual);
4519 else if (TYPE_CODE (formal_type) != TYPE_CODE_PTR)
4520 {
4521 if (VALUE_LVAL (actual) != lval_memory)
4522 {
4523 struct value *val;
4524
4525 actual_type = ada_check_typedef (value_type (actual));
4526 val = allocate_value (actual_type);
4527 memcpy ((char *) value_contents_raw (val),
4528 (char *) value_contents (actual),
4529 TYPE_LENGTH (actual_type));
4530 actual = ensure_lval (val);
4531 }
4532 result = value_addr (actual);
4533 }
4534 else
4535 return actual;
4536 return value_cast_pointers (formal_type, result, 0);
4537 }
4538 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4539 return ada_value_ind (actual);
4540 else if (ada_is_aligner_type (formal_type))
4541 {
4542 /* We need to turn this parameter into an aligner type
4543 as well. */
4544 struct value *aligner = allocate_value (formal_type);
4545 struct value *component = ada_value_struct_elt (aligner, "F", 0);
4546
4547 value_assign_to_component (aligner, component, actual);
4548 return aligner;
4549 }
4550
4551 return actual;
4552 }
4553
4554 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4555 type TYPE. This is usually an inefficient no-op except on some targets
4556 (such as AVR) where the representation of a pointer and an address
4557 differs. */
4558
4559 static CORE_ADDR
4560 value_pointer (struct value *value, struct type *type)
4561 {
4562 struct gdbarch *gdbarch = get_type_arch (type);
4563 unsigned len = TYPE_LENGTH (type);
4564 gdb_byte *buf = (gdb_byte *) alloca (len);
4565 CORE_ADDR addr;
4566
4567 addr = value_address (value);
4568 gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4569 addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4570 return addr;
4571 }
4572
4573
4574 /* Push a descriptor of type TYPE for array value ARR on the stack at
4575 *SP, updating *SP to reflect the new descriptor. Return either
4576 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4577 to-descriptor type rather than a descriptor type), a struct value *
4578 representing a pointer to this descriptor. */
4579
4580 static struct value *
4581 make_array_descriptor (struct type *type, struct value *arr)
4582 {
4583 struct type *bounds_type = desc_bounds_type (type);
4584 struct type *desc_type = desc_base_type (type);
4585 struct value *descriptor = allocate_value (desc_type);
4586 struct value *bounds = allocate_value (bounds_type);
4587 int i;
4588
4589 for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4590 i > 0; i -= 1)
4591 {
4592 modify_field (value_type (bounds), value_contents_writeable (bounds),
4593 ada_array_bound (arr, i, 0),
4594 desc_bound_bitpos (bounds_type, i, 0),
4595 desc_bound_bitsize (bounds_type, i, 0));
4596 modify_field (value_type (bounds), value_contents_writeable (bounds),
4597 ada_array_bound (arr, i, 1),
4598 desc_bound_bitpos (bounds_type, i, 1),
4599 desc_bound_bitsize (bounds_type, i, 1));
4600 }
4601
4602 bounds = ensure_lval (bounds);
4603
4604 modify_field (value_type (descriptor),
4605 value_contents_writeable (descriptor),
4606 value_pointer (ensure_lval (arr),
4607 TYPE_FIELD_TYPE (desc_type, 0)),
4608 fat_pntr_data_bitpos (desc_type),
4609 fat_pntr_data_bitsize (desc_type));
4610
4611 modify_field (value_type (descriptor),
4612 value_contents_writeable (descriptor),
4613 value_pointer (bounds,
4614 TYPE_FIELD_TYPE (desc_type, 1)),
4615 fat_pntr_bounds_bitpos (desc_type),
4616 fat_pntr_bounds_bitsize (desc_type));
4617
4618 descriptor = ensure_lval (descriptor);
4619
4620 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4621 return value_addr (descriptor);
4622 else
4623 return descriptor;
4624 }
4625
4626 /* Symbol Cache Module */
4627
4628 /* Performance measurements made as of 2010-01-15 indicate that
4629 this cache does bring some noticeable improvements. Depending
4630 on the type of entity being printed, the cache can make it as much
4631 as an order of magnitude faster than without it.
4632
4633 The descriptive type DWARF extension has significantly reduced
4634 the need for this cache, at least when DWARF is being used. However,
4635 even in this case, some expensive name-based symbol searches are still
4636 sometimes necessary - to find an XVZ variable, mostly. */
4637
4638 /* Initialize the contents of SYM_CACHE. */
4639
4640 static void
4641 ada_init_symbol_cache (struct ada_symbol_cache *sym_cache)
4642 {
4643 obstack_init (&sym_cache->cache_space);
4644 memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4645 }
4646
4647 /* Free the memory used by SYM_CACHE. */
4648
4649 static void
4650 ada_free_symbol_cache (struct ada_symbol_cache *sym_cache)
4651 {
4652 obstack_free (&sym_cache->cache_space, NULL);
4653 xfree (sym_cache);
4654 }
4655
4656 /* Return the symbol cache associated to the given program space PSPACE.
4657 If not allocated for this PSPACE yet, allocate and initialize one. */
4658
4659 static struct ada_symbol_cache *
4660 ada_get_symbol_cache (struct program_space *pspace)
4661 {
4662 struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4663
4664 if (pspace_data->sym_cache == NULL)
4665 {
4666 pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4667 ada_init_symbol_cache (pspace_data->sym_cache);
4668 }
4669
4670 return pspace_data->sym_cache;
4671 }
4672
4673 /* Clear all entries from the symbol cache. */
4674
4675 static void
4676 ada_clear_symbol_cache (void)
4677 {
4678 struct ada_symbol_cache *sym_cache
4679 = ada_get_symbol_cache (current_program_space);
4680
4681 obstack_free (&sym_cache->cache_space, NULL);
4682 ada_init_symbol_cache (sym_cache);
4683 }
4684
4685 /* Search our cache for an entry matching NAME and DOMAIN.
4686 Return it if found, or NULL otherwise. */
4687
4688 static struct cache_entry **
4689 find_entry (const char *name, domain_enum domain)
4690 {
4691 struct ada_symbol_cache *sym_cache
4692 = ada_get_symbol_cache (current_program_space);
4693 int h = msymbol_hash (name) % HASH_SIZE;
4694 struct cache_entry **e;
4695
4696 for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4697 {
4698 if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4699 return e;
4700 }
4701 return NULL;
4702 }
4703
4704 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4705 Return 1 if found, 0 otherwise.
4706
4707 If an entry was found and SYM is not NULL, set *SYM to the entry's
4708 SYM. Same principle for BLOCK if not NULL. */
4709
4710 static int
4711 lookup_cached_symbol (const char *name, domain_enum domain,
4712 struct symbol **sym, const struct block **block)
4713 {
4714 struct cache_entry **e = find_entry (name, domain);
4715
4716 if (e == NULL)
4717 return 0;
4718 if (sym != NULL)
4719 *sym = (*e)->sym;
4720 if (block != NULL)
4721 *block = (*e)->block;
4722 return 1;
4723 }
4724
4725 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4726 in domain DOMAIN, save this result in our symbol cache. */
4727
4728 static void
4729 cache_symbol (const char *name, domain_enum domain, struct symbol *sym,
4730 const struct block *block)
4731 {
4732 struct ada_symbol_cache *sym_cache
4733 = ada_get_symbol_cache (current_program_space);
4734 int h;
4735 char *copy;
4736 struct cache_entry *e;
4737
4738 /* Symbols for builtin types don't have a block.
4739 For now don't cache such symbols. */
4740 if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4741 return;
4742
4743 /* If the symbol is a local symbol, then do not cache it, as a search
4744 for that symbol depends on the context. To determine whether
4745 the symbol is local or not, we check the block where we found it
4746 against the global and static blocks of its associated symtab. */
4747 if (sym
4748 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4749 GLOBAL_BLOCK) != block
4750 && BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (symbol_symtab (sym)),
4751 STATIC_BLOCK) != block)
4752 return;
4753
4754 h = msymbol_hash (name) % HASH_SIZE;
4755 e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4756 sizeof (*e));
4757 e->next = sym_cache->root[h];
4758 sym_cache->root[h] = e;
4759 e->name = copy
4760 = (char *) obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
4761 strcpy (copy, name);
4762 e->sym = sym;
4763 e->domain = domain;
4764 e->block = block;
4765 }
4766
4767 /* Symbol Lookup */
4768
4769 /* Return the symbol name match type that should be used used when
4770 searching for all symbols matching LOOKUP_NAME.
4771
4772 LOOKUP_NAME is expected to be a symbol name after transformation
4773 for Ada lookups (see ada_name_for_lookup). */
4774
4775 static symbol_name_match_type
4776 name_match_type_from_name (const char *lookup_name)
4777 {
4778 return (strstr (lookup_name, "__") == NULL
4779 ? symbol_name_match_type::WILD
4780 : symbol_name_match_type::FULL);
4781 }
4782
4783 /* Return the result of a standard (literal, C-like) lookup of NAME in
4784 given DOMAIN, visible from lexical block BLOCK. */
4785
4786 static struct symbol *
4787 standard_lookup (const char *name, const struct block *block,
4788 domain_enum domain)
4789 {
4790 /* Initialize it just to avoid a GCC false warning. */
4791 struct block_symbol sym = {NULL, NULL};
4792
4793 if (lookup_cached_symbol (name, domain, &sym.symbol, NULL))
4794 return sym.symbol;
4795 sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4796 cache_symbol (name, domain, sym.symbol, sym.block);
4797 return sym.symbol;
4798 }
4799
4800
4801 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4802 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4803 since they contend in overloading in the same way. */
4804 static int
4805 is_nonfunction (struct block_symbol syms[], int n)
4806 {
4807 int i;
4808
4809 for (i = 0; i < n; i += 1)
4810 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_FUNC
4811 && (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM
4812 || SYMBOL_CLASS (syms[i].symbol) != LOC_CONST))
4813 return 1;
4814
4815 return 0;
4816 }
4817
4818 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4819 struct types. Otherwise, they may not. */
4820
4821 static int
4822 equiv_types (struct type *type0, struct type *type1)
4823 {
4824 if (type0 == type1)
4825 return 1;
4826 if (type0 == NULL || type1 == NULL
4827 || TYPE_CODE (type0) != TYPE_CODE (type1))
4828 return 0;
4829 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4830 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4831 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4832 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4833 return 1;
4834
4835 return 0;
4836 }
4837
4838 /* True iff SYM0 represents the same entity as SYM1, or one that is
4839 no more defined than that of SYM1. */
4840
4841 static int
4842 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4843 {
4844 if (sym0 == sym1)
4845 return 1;
4846 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4847 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4848 return 0;
4849
4850 switch (SYMBOL_CLASS (sym0))
4851 {
4852 case LOC_UNDEF:
4853 return 1;
4854 case LOC_TYPEDEF:
4855 {
4856 struct type *type0 = SYMBOL_TYPE (sym0);
4857 struct type *type1 = SYMBOL_TYPE (sym1);
4858 const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4859 const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4860 int len0 = strlen (name0);
4861
4862 return
4863 TYPE_CODE (type0) == TYPE_CODE (type1)
4864 && (equiv_types (type0, type1)
4865 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4866 && startswith (name1 + len0, "___XV")));
4867 }
4868 case LOC_CONST:
4869 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4870 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4871 default:
4872 return 0;
4873 }
4874 }
4875
4876 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct block_symbol
4877 records in OBSTACKP. Do nothing if SYM is a duplicate. */
4878
4879 static void
4880 add_defn_to_vec (struct obstack *obstackp,
4881 struct symbol *sym,
4882 const struct block *block)
4883 {
4884 int i;
4885 struct block_symbol *prevDefns = defns_collected (obstackp, 0);
4886
4887 /* Do not try to complete stub types, as the debugger is probably
4888 already scanning all symbols matching a certain name at the
4889 time when this function is called. Trying to replace the stub
4890 type by its associated full type will cause us to restart a scan
4891 which may lead to an infinite recursion. Instead, the client
4892 collecting the matching symbols will end up collecting several
4893 matches, with at least one of them complete. It can then filter
4894 out the stub ones if needed. */
4895
4896 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4897 {
4898 if (lesseq_defined_than (sym, prevDefns[i].symbol))
4899 return;
4900 else if (lesseq_defined_than (prevDefns[i].symbol, sym))
4901 {
4902 prevDefns[i].symbol = sym;
4903 prevDefns[i].block = block;
4904 return;
4905 }
4906 }
4907
4908 {
4909 struct block_symbol info;
4910
4911 info.symbol = sym;
4912 info.block = block;
4913 obstack_grow (obstackp, &info, sizeof (struct block_symbol));
4914 }
4915 }
4916
4917 /* Number of block_symbol structures currently collected in current vector in
4918 OBSTACKP. */
4919
4920 static int
4921 num_defns_collected (struct obstack *obstackp)
4922 {
4923 return obstack_object_size (obstackp) / sizeof (struct block_symbol);
4924 }
4925
4926 /* Vector of block_symbol structures currently collected in current vector in
4927 OBSTACKP. If FINISH, close off the vector and return its final address. */
4928
4929 static struct block_symbol *
4930 defns_collected (struct obstack *obstackp, int finish)
4931 {
4932 if (finish)
4933 return (struct block_symbol *) obstack_finish (obstackp);
4934 else
4935 return (struct block_symbol *) obstack_base (obstackp);
4936 }
4937
4938 /* Return a bound minimal symbol matching NAME according to Ada
4939 decoding rules. Returns an invalid symbol if there is no such
4940 minimal symbol. Names prefixed with "standard__" are handled
4941 specially: "standard__" is first stripped off, and only static and
4942 global symbols are searched. */
4943
4944 struct bound_minimal_symbol
4945 ada_lookup_simple_minsym (const char *name)
4946 {
4947 struct bound_minimal_symbol result;
4948 struct objfile *objfile;
4949 struct minimal_symbol *msymbol;
4950
4951 memset (&result, 0, sizeof (result));
4952
4953 symbol_name_match_type match_type = name_match_type_from_name (name);
4954 lookup_name_info lookup_name (name, match_type);
4955
4956 symbol_name_matcher_ftype *match_name
4957 = ada_get_symbol_name_matcher (lookup_name);
4958
4959 ALL_MSYMBOLS (objfile, msymbol)
4960 {
4961 if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), lookup_name, NULL)
4962 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4963 {
4964 result.minsym = msymbol;
4965 result.objfile = objfile;
4966 break;
4967 }
4968 }
4969
4970 return result;
4971 }
4972
4973 /* For all subprograms that statically enclose the subprogram of the
4974 selected frame, add symbols matching identifier NAME in DOMAIN
4975 and their blocks to the list of data in OBSTACKP, as for
4976 ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4977 with a wildcard prefix. */
4978
4979 static void
4980 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4981 const lookup_name_info &lookup_name,
4982 domain_enum domain)
4983 {
4984 }
4985
4986 /* True if TYPE is definitely an artificial type supplied to a symbol
4987 for which no debugging information was given in the symbol file. */
4988
4989 static int
4990 is_nondebugging_type (struct type *type)
4991 {
4992 const char *name = ada_type_name (type);
4993
4994 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4995 }
4996
4997 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4998 that are deemed "identical" for practical purposes.
4999
5000 This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
5001 types and that their number of enumerals is identical (in other
5002 words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
5003
5004 static int
5005 ada_identical_enum_types_p (struct type *type1, struct type *type2)
5006 {
5007 int i;
5008
5009 /* The heuristic we use here is fairly conservative. We consider
5010 that 2 enumerate types are identical if they have the same
5011 number of enumerals and that all enumerals have the same
5012 underlying value and name. */
5013
5014 /* All enums in the type should have an identical underlying value. */
5015 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5016 if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
5017 return 0;
5018
5019 /* All enumerals should also have the same name (modulo any numerical
5020 suffix). */
5021 for (i = 0; i < TYPE_NFIELDS (type1); i++)
5022 {
5023 const char *name_1 = TYPE_FIELD_NAME (type1, i);
5024 const char *name_2 = TYPE_FIELD_NAME (type2, i);
5025 int len_1 = strlen (name_1);
5026 int len_2 = strlen (name_2);
5027
5028 ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
5029 ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
5030 if (len_1 != len_2
5031 || strncmp (TYPE_FIELD_NAME (type1, i),
5032 TYPE_FIELD_NAME (type2, i),
5033 len_1) != 0)
5034 return 0;
5035 }
5036
5037 return 1;
5038 }
5039
5040 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
5041 that are deemed "identical" for practical purposes. Sometimes,
5042 enumerals are not strictly identical, but their types are so similar
5043 that they can be considered identical.
5044
5045 For instance, consider the following code:
5046
5047 type Color is (Black, Red, Green, Blue, White);
5048 type RGB_Color is new Color range Red .. Blue;
5049
5050 Type RGB_Color is a subrange of an implicit type which is a copy
5051 of type Color. If we call that implicit type RGB_ColorB ("B" is
5052 for "Base Type"), then type RGB_ColorB is a copy of type Color.
5053 As a result, when an expression references any of the enumeral
5054 by name (Eg. "print green"), the expression is technically
5055 ambiguous and the user should be asked to disambiguate. But
5056 doing so would only hinder the user, since it wouldn't matter
5057 what choice he makes, the outcome would always be the same.
5058 So, for practical purposes, we consider them as the same. */
5059
5060 static int
5061 symbols_are_identical_enums (struct block_symbol *syms, int nsyms)
5062 {
5063 int i;
5064
5065 /* Before performing a thorough comparison check of each type,
5066 we perform a series of inexpensive checks. We expect that these
5067 checks will quickly fail in the vast majority of cases, and thus
5068 help prevent the unnecessary use of a more expensive comparison.
5069 Said comparison also expects us to make some of these checks
5070 (see ada_identical_enum_types_p). */
5071
5072 /* Quick check: All symbols should have an enum type. */
5073 for (i = 0; i < nsyms; i++)
5074 if (TYPE_CODE (SYMBOL_TYPE (syms[i].symbol)) != TYPE_CODE_ENUM)
5075 return 0;
5076
5077 /* Quick check: They should all have the same value. */
5078 for (i = 1; i < nsyms; i++)
5079 if (SYMBOL_VALUE (syms[i].symbol) != SYMBOL_VALUE (syms[0].symbol))
5080 return 0;
5081
5082 /* Quick check: They should all have the same number of enumerals. */
5083 for (i = 1; i < nsyms; i++)
5084 if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].symbol))
5085 != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].symbol)))
5086 return 0;
5087
5088 /* All the sanity checks passed, so we might have a set of
5089 identical enumeration types. Perform a more complete
5090 comparison of the type of each symbol. */
5091 for (i = 1; i < nsyms; i++)
5092 if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].symbol),
5093 SYMBOL_TYPE (syms[0].symbol)))
5094 return 0;
5095
5096 return 1;
5097 }
5098
5099 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
5100 duplicate other symbols in the list (The only case I know of where
5101 this happens is when object files containing stabs-in-ecoff are
5102 linked with files containing ordinary ecoff debugging symbols (or no
5103 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
5104 Returns the number of items in the modified list. */
5105
5106 static int
5107 remove_extra_symbols (struct block_symbol *syms, int nsyms)
5108 {
5109 int i, j;
5110
5111 /* We should never be called with less than 2 symbols, as there
5112 cannot be any extra symbol in that case. But it's easy to
5113 handle, since we have nothing to do in that case. */
5114 if (nsyms < 2)
5115 return nsyms;
5116
5117 i = 0;
5118 while (i < nsyms)
5119 {
5120 int remove_p = 0;
5121
5122 /* If two symbols have the same name and one of them is a stub type,
5123 the get rid of the stub. */
5124
5125 if (TYPE_STUB (SYMBOL_TYPE (syms[i].symbol))
5126 && SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL)
5127 {
5128 for (j = 0; j < nsyms; j++)
5129 {
5130 if (j != i
5131 && !TYPE_STUB (SYMBOL_TYPE (syms[j].symbol))
5132 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5133 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5134 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0)
5135 remove_p = 1;
5136 }
5137 }
5138
5139 /* Two symbols with the same name, same class and same address
5140 should be identical. */
5141
5142 else if (SYMBOL_LINKAGE_NAME (syms[i].symbol) != NULL
5143 && SYMBOL_CLASS (syms[i].symbol) == LOC_STATIC
5144 && is_nondebugging_type (SYMBOL_TYPE (syms[i].symbol)))
5145 {
5146 for (j = 0; j < nsyms; j += 1)
5147 {
5148 if (i != j
5149 && SYMBOL_LINKAGE_NAME (syms[j].symbol) != NULL
5150 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].symbol),
5151 SYMBOL_LINKAGE_NAME (syms[j].symbol)) == 0
5152 && SYMBOL_CLASS (syms[i].symbol)
5153 == SYMBOL_CLASS (syms[j].symbol)
5154 && SYMBOL_VALUE_ADDRESS (syms[i].symbol)
5155 == SYMBOL_VALUE_ADDRESS (syms[j].symbol))
5156 remove_p = 1;
5157 }
5158 }
5159
5160 if (remove_p)
5161 {
5162 for (j = i + 1; j < nsyms; j += 1)
5163 syms[j - 1] = syms[j];
5164 nsyms -= 1;
5165 }
5166
5167 i += 1;
5168 }
5169
5170 /* If all the remaining symbols are identical enumerals, then
5171 just keep the first one and discard the rest.
5172
5173 Unlike what we did previously, we do not discard any entry
5174 unless they are ALL identical. This is because the symbol
5175 comparison is not a strict comparison, but rather a practical
5176 comparison. If all symbols are considered identical, then
5177 we can just go ahead and use the first one and discard the rest.
5178 But if we cannot reduce the list to a single element, we have
5179 to ask the user to disambiguate anyways. And if we have to
5180 present a multiple-choice menu, it's less confusing if the list
5181 isn't missing some choices that were identical and yet distinct. */
5182 if (symbols_are_identical_enums (syms, nsyms))
5183 nsyms = 1;
5184
5185 return nsyms;
5186 }
5187
5188 /* Given a type that corresponds to a renaming entity, use the type name
5189 to extract the scope (package name or function name, fully qualified,
5190 and following the GNAT encoding convention) where this renaming has been
5191 defined. The string returned needs to be deallocated after use. */
5192
5193 static char *
5194 xget_renaming_scope (struct type *renaming_type)
5195 {
5196 /* The renaming types adhere to the following convention:
5197 <scope>__<rename>___<XR extension>.
5198 So, to extract the scope, we search for the "___XR" extension,
5199 and then backtrack until we find the first "__". */
5200
5201 const char *name = type_name_no_tag (renaming_type);
5202 const char *suffix = strstr (name, "___XR");
5203 const char *last;
5204 int scope_len;
5205 char *scope;
5206
5207 /* Now, backtrack a bit until we find the first "__". Start looking
5208 at suffix - 3, as the <rename> part is at least one character long. */
5209
5210 for (last = suffix - 3; last > name; last--)
5211 if (last[0] == '_' && last[1] == '_')
5212 break;
5213
5214 /* Make a copy of scope and return it. */
5215
5216 scope_len = last - name;
5217 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
5218
5219 strncpy (scope, name, scope_len);
5220 scope[scope_len] = '\0';
5221
5222 return scope;
5223 }
5224
5225 /* Return nonzero if NAME corresponds to a package name. */
5226
5227 static int
5228 is_package_name (const char *name)
5229 {
5230 /* Here, We take advantage of the fact that no symbols are generated
5231 for packages, while symbols are generated for each function.
5232 So the condition for NAME represent a package becomes equivalent
5233 to NAME not existing in our list of symbols. There is only one
5234 small complication with library-level functions (see below). */
5235
5236 char *fun_name;
5237
5238 /* If it is a function that has not been defined at library level,
5239 then we should be able to look it up in the symbols. */
5240 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5241 return 0;
5242
5243 /* Library-level function names start with "_ada_". See if function
5244 "_ada_" followed by NAME can be found. */
5245
5246 /* Do a quick check that NAME does not contain "__", since library-level
5247 functions names cannot contain "__" in them. */
5248 if (strstr (name, "__") != NULL)
5249 return 0;
5250
5251 fun_name = xstrprintf ("_ada_%s", name);
5252
5253 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5254 }
5255
5256 /* Return nonzero if SYM corresponds to a renaming entity that is
5257 not visible from FUNCTION_NAME. */
5258
5259 static int
5260 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5261 {
5262 char *scope;
5263 struct cleanup *old_chain;
5264
5265 if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5266 return 0;
5267
5268 scope = xget_renaming_scope (SYMBOL_TYPE (sym));
5269 old_chain = make_cleanup (xfree, scope);
5270
5271 /* If the rename has been defined in a package, then it is visible. */
5272 if (is_package_name (scope))
5273 {
5274 do_cleanups (old_chain);
5275 return 0;
5276 }
5277
5278 /* Check that the rename is in the current function scope by checking
5279 that its name starts with SCOPE. */
5280
5281 /* If the function name starts with "_ada_", it means that it is
5282 a library-level function. Strip this prefix before doing the
5283 comparison, as the encoding for the renaming does not contain
5284 this prefix. */
5285 if (startswith (function_name, "_ada_"))
5286 function_name += 5;
5287
5288 {
5289 int is_invisible = !startswith (function_name, scope);
5290
5291 do_cleanups (old_chain);
5292 return is_invisible;
5293 }
5294 }
5295
5296 /* Remove entries from SYMS that corresponds to a renaming entity that
5297 is not visible from the function associated with CURRENT_BLOCK or
5298 that is superfluous due to the presence of more specific renaming
5299 information. Places surviving symbols in the initial entries of
5300 SYMS and returns the number of surviving symbols.
5301
5302 Rationale:
5303 First, in cases where an object renaming is implemented as a
5304 reference variable, GNAT may produce both the actual reference
5305 variable and the renaming encoding. In this case, we discard the
5306 latter.
5307
5308 Second, GNAT emits a type following a specified encoding for each renaming
5309 entity. Unfortunately, STABS currently does not support the definition
5310 of types that are local to a given lexical block, so all renamings types
5311 are emitted at library level. As a consequence, if an application
5312 contains two renaming entities using the same name, and a user tries to
5313 print the value of one of these entities, the result of the ada symbol
5314 lookup will also contain the wrong renaming type.
5315
5316 This function partially covers for this limitation by attempting to
5317 remove from the SYMS list renaming symbols that should be visible
5318 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5319 method with the current information available. The implementation
5320 below has a couple of limitations (FIXME: brobecker-2003-05-12):
5321
5322 - When the user tries to print a rename in a function while there
5323 is another rename entity defined in a package: Normally, the
5324 rename in the function has precedence over the rename in the
5325 package, so the latter should be removed from the list. This is
5326 currently not the case.
5327
5328 - This function will incorrectly remove valid renames if
5329 the CURRENT_BLOCK corresponds to a function which symbol name
5330 has been changed by an "Export" pragma. As a consequence,
5331 the user will be unable to print such rename entities. */
5332
5333 static int
5334 remove_irrelevant_renamings (struct block_symbol *syms,
5335 int nsyms, const struct block *current_block)
5336 {
5337 struct symbol *current_function;
5338 const char *current_function_name;
5339 int i;
5340 int is_new_style_renaming;
5341
5342 /* If there is both a renaming foo___XR... encoded as a variable and
5343 a simple variable foo in the same block, discard the latter.
5344 First, zero out such symbols, then compress. */
5345 is_new_style_renaming = 0;
5346 for (i = 0; i < nsyms; i += 1)
5347 {
5348 struct symbol *sym = syms[i].symbol;
5349 const struct block *block = syms[i].block;
5350 const char *name;
5351 const char *suffix;
5352
5353 if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5354 continue;
5355 name = SYMBOL_LINKAGE_NAME (sym);
5356 suffix = strstr (name, "___XR");
5357
5358 if (suffix != NULL)
5359 {
5360 int name_len = suffix - name;
5361 int j;
5362
5363 is_new_style_renaming = 1;
5364 for (j = 0; j < nsyms; j += 1)
5365 if (i != j && syms[j].symbol != NULL
5366 && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].symbol),
5367 name_len) == 0
5368 && block == syms[j].block)
5369 syms[j].symbol = NULL;
5370 }
5371 }
5372 if (is_new_style_renaming)
5373 {
5374 int j, k;
5375
5376 for (j = k = 0; j < nsyms; j += 1)
5377 if (syms[j].symbol != NULL)
5378 {
5379 syms[k] = syms[j];
5380 k += 1;
5381 }
5382 return k;
5383 }
5384
5385 /* Extract the function name associated to CURRENT_BLOCK.
5386 Abort if unable to do so. */
5387
5388 if (current_block == NULL)
5389 return nsyms;
5390
5391 current_function = block_linkage_function (current_block);
5392 if (current_function == NULL)
5393 return nsyms;
5394
5395 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5396 if (current_function_name == NULL)
5397 return nsyms;
5398
5399 /* Check each of the symbols, and remove it from the list if it is
5400 a type corresponding to a renaming that is out of the scope of
5401 the current block. */
5402
5403 i = 0;
5404 while (i < nsyms)
5405 {
5406 if (ada_parse_renaming (syms[i].symbol, NULL, NULL, NULL)
5407 == ADA_OBJECT_RENAMING
5408 && old_renaming_is_invisible (syms[i].symbol, current_function_name))
5409 {
5410 int j;
5411
5412 for (j = i + 1; j < nsyms; j += 1)
5413 syms[j - 1] = syms[j];
5414 nsyms -= 1;
5415 }
5416 else
5417 i += 1;
5418 }
5419
5420 return nsyms;
5421 }
5422
5423 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5424 whose name and domain match NAME and DOMAIN respectively.
5425 If no match was found, then extend the search to "enclosing"
5426 routines (in other words, if we're inside a nested function,
5427 search the symbols defined inside the enclosing functions).
5428 If WILD_MATCH_P is nonzero, perform the naming matching in
5429 "wild" mode (see function "wild_match" for more info).
5430
5431 Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5432
5433 static void
5434 ada_add_local_symbols (struct obstack *obstackp,
5435 const lookup_name_info &lookup_name,
5436 const struct block *block, domain_enum domain)
5437 {
5438 int block_depth = 0;
5439
5440 while (block != NULL)
5441 {
5442 block_depth += 1;
5443 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5444
5445 /* If we found a non-function match, assume that's the one. */
5446 if (is_nonfunction (defns_collected (obstackp, 0),
5447 num_defns_collected (obstackp)))
5448 return;
5449
5450 block = BLOCK_SUPERBLOCK (block);
5451 }
5452
5453 /* If no luck so far, try to find NAME as a local symbol in some lexically
5454 enclosing subprogram. */
5455 if (num_defns_collected (obstackp) == 0 && block_depth > 2)
5456 add_symbols_from_enclosing_procs (obstackp, lookup_name, domain);
5457 }
5458
5459 /* An object of this type is used as the user_data argument when
5460 calling the map_matching_symbols method. */
5461
5462 struct match_data
5463 {
5464 struct objfile *objfile;
5465 struct obstack *obstackp;
5466 struct symbol *arg_sym;
5467 int found_sym;
5468 };
5469
5470 /* A callback for add_nonlocal_symbols that adds SYM, found in BLOCK,
5471 to a list of symbols. DATA0 is a pointer to a struct match_data *
5472 containing the obstack that collects the symbol list, the file that SYM
5473 must come from, a flag indicating whether a non-argument symbol has
5474 been found in the current block, and the last argument symbol
5475 passed in SYM within the current block (if any). When SYM is null,
5476 marking the end of a block, the argument symbol is added if no
5477 other has been found. */
5478
5479 static int
5480 aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
5481 {
5482 struct match_data *data = (struct match_data *) data0;
5483
5484 if (sym == NULL)
5485 {
5486 if (!data->found_sym && data->arg_sym != NULL)
5487 add_defn_to_vec (data->obstackp,
5488 fixup_symbol_section (data->arg_sym, data->objfile),
5489 block);
5490 data->found_sym = 0;
5491 data->arg_sym = NULL;
5492 }
5493 else
5494 {
5495 if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5496 return 0;
5497 else if (SYMBOL_IS_ARGUMENT (sym))
5498 data->arg_sym = sym;
5499 else
5500 {
5501 data->found_sym = 1;
5502 add_defn_to_vec (data->obstackp,
5503 fixup_symbol_section (sym, data->objfile),
5504 block);
5505 }
5506 }
5507 return 0;
5508 }
5509
5510 /* Helper for add_nonlocal_symbols. Find symbols in DOMAIN which are
5511 targeted by renamings matching LOOKUP_NAME in BLOCK. Add these
5512 symbols to OBSTACKP. Return whether we found such symbols. */
5513
5514 static int
5515 ada_add_block_renamings (struct obstack *obstackp,
5516 const struct block *block,
5517 const lookup_name_info &lookup_name,
5518 domain_enum domain)
5519 {
5520 struct using_direct *renaming;
5521 int defns_mark = num_defns_collected (obstackp);
5522
5523 symbol_name_matcher_ftype *name_match
5524 = ada_get_symbol_name_matcher (lookup_name);
5525
5526 for (renaming = block_using (block);
5527 renaming != NULL;
5528 renaming = renaming->next)
5529 {
5530 const char *r_name;
5531
5532 /* Avoid infinite recursions: skip this renaming if we are actually
5533 already traversing it.
5534
5535 Currently, symbol lookup in Ada don't use the namespace machinery from
5536 C++/Fortran support: skip namespace imports that use them. */
5537 if (renaming->searched
5538 || (renaming->import_src != NULL
5539 && renaming->import_src[0] != '\0')
5540 || (renaming->import_dest != NULL
5541 && renaming->import_dest[0] != '\0'))
5542 continue;
5543 renaming->searched = 1;
5544
5545 /* TODO: here, we perform another name-based symbol lookup, which can
5546 pull its own multiple overloads. In theory, we should be able to do
5547 better in this case since, in DWARF, DW_AT_import is a DIE reference,
5548 not a simple name. But in order to do this, we would need to enhance
5549 the DWARF reader to associate a symbol to this renaming, instead of a
5550 name. So, for now, we do something simpler: re-use the C++/Fortran
5551 namespace machinery. */
5552 r_name = (renaming->alias != NULL
5553 ? renaming->alias
5554 : renaming->declaration);
5555 if (name_match (r_name, lookup_name, NULL))
5556 {
5557 lookup_name_info decl_lookup_name (renaming->declaration,
5558 lookup_name.match_type ());
5559 ada_add_all_symbols (obstackp, block, decl_lookup_name, domain,
5560 1, NULL);
5561 }
5562 renaming->searched = 0;
5563 }
5564 return num_defns_collected (obstackp) != defns_mark;
5565 }
5566
5567 /* Implements compare_names, but only applying the comparision using
5568 the given CASING. */
5569
5570 static int
5571 compare_names_with_case (const char *string1, const char *string2,
5572 enum case_sensitivity casing)
5573 {
5574 while (*string1 != '\0' && *string2 != '\0')
5575 {
5576 char c1, c2;
5577
5578 if (isspace (*string1) || isspace (*string2))
5579 return strcmp_iw_ordered (string1, string2);
5580
5581 if (casing == case_sensitive_off)
5582 {
5583 c1 = tolower (*string1);
5584 c2 = tolower (*string2);
5585 }
5586 else
5587 {
5588 c1 = *string1;
5589 c2 = *string2;
5590 }
5591 if (c1 != c2)
5592 break;
5593
5594 string1 += 1;
5595 string2 += 1;
5596 }
5597
5598 switch (*string1)
5599 {
5600 case '(':
5601 return strcmp_iw_ordered (string1, string2);
5602 case '_':
5603 if (*string2 == '\0')
5604 {
5605 if (is_name_suffix (string1))
5606 return 0;
5607 else
5608 return 1;
5609 }
5610 /* FALLTHROUGH */
5611 default:
5612 if (*string2 == '(')
5613 return strcmp_iw_ordered (string1, string2);
5614 else
5615 {
5616 if (casing == case_sensitive_off)
5617 return tolower (*string1) - tolower (*string2);
5618 else
5619 return *string1 - *string2;
5620 }
5621 }
5622 }
5623
5624 /* Compare STRING1 to STRING2, with results as for strcmp.
5625 Compatible with strcmp_iw_ordered in that...
5626
5627 strcmp_iw_ordered (STRING1, STRING2) <= 0
5628
5629 ... implies...
5630
5631 compare_names (STRING1, STRING2) <= 0
5632
5633 (they may differ as to what symbols compare equal). */
5634
5635 static int
5636 compare_names (const char *string1, const char *string2)
5637 {
5638 int result;
5639
5640 /* Similar to what strcmp_iw_ordered does, we need to perform
5641 a case-insensitive comparison first, and only resort to
5642 a second, case-sensitive, comparison if the first one was
5643 not sufficient to differentiate the two strings. */
5644
5645 result = compare_names_with_case (string1, string2, case_sensitive_off);
5646 if (result == 0)
5647 result = compare_names_with_case (string1, string2, case_sensitive_on);
5648
5649 return result;
5650 }
5651
5652 /* Convenience function to get at the Ada encoded lookup name for
5653 LOOKUP_NAME, as a C string. */
5654
5655 static const char *
5656 ada_lookup_name (const lookup_name_info &lookup_name)
5657 {
5658 return lookup_name.ada ().lookup_name ().c_str ();
5659 }
5660
5661 /* Add to OBSTACKP all non-local symbols whose name and domain match
5662 LOOKUP_NAME and DOMAIN respectively. The search is performed on
5663 GLOBAL_BLOCK symbols if GLOBAL is non-zero, or on STATIC_BLOCK
5664 symbols otherwise. */
5665
5666 static void
5667 add_nonlocal_symbols (struct obstack *obstackp,
5668 const lookup_name_info &lookup_name,
5669 domain_enum domain, int global)
5670 {
5671 struct objfile *objfile;
5672 struct compunit_symtab *cu;
5673 struct match_data data;
5674
5675 memset (&data, 0, sizeof data);
5676 data.obstackp = obstackp;
5677
5678 bool is_wild_match = lookup_name.ada ().wild_match_p ();
5679
5680 ALL_OBJFILES (objfile)
5681 {
5682 data.objfile = objfile;
5683
5684 if (is_wild_match)
5685 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5686 domain, global,
5687 aux_add_nonlocal_symbols, &data,
5688 symbol_name_match_type::WILD,
5689 NULL);
5690 else
5691 objfile->sf->qf->map_matching_symbols (objfile, lookup_name.name ().c_str (),
5692 domain, global,
5693 aux_add_nonlocal_symbols, &data,
5694 symbol_name_match_type::FULL,
5695 compare_names);
5696
5697 ALL_OBJFILE_COMPUNITS (objfile, cu)
5698 {
5699 const struct block *global_block
5700 = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (cu), GLOBAL_BLOCK);
5701
5702 if (ada_add_block_renamings (obstackp, global_block, lookup_name,
5703 domain))
5704 data.found_sym = 1;
5705 }
5706 }
5707
5708 if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5709 {
5710 const char *name = ada_lookup_name (lookup_name);
5711 std::string name1 = std::string ("<_ada_") + name + '>';
5712
5713 ALL_OBJFILES (objfile)
5714 {
5715 data.objfile = objfile;
5716 objfile->sf->qf->map_matching_symbols (objfile, name1.c_str (),
5717 domain, global,
5718 aux_add_nonlocal_symbols,
5719 &data,
5720 symbol_name_match_type::FULL,
5721 compare_names);
5722 }
5723 }
5724 }
5725
5726 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if
5727 FULL_SEARCH is non-zero, enclosing scope and in global scopes,
5728 returning the number of matches. Add these to OBSTACKP.
5729
5730 When FULL_SEARCH is non-zero, any non-function/non-enumeral
5731 symbol match within the nest of blocks whose innermost member is BLOCK,
5732 is the one match returned (no other matches in that or
5733 enclosing blocks is returned). If there are any matches in or
5734 surrounding BLOCK, then these alone are returned.
5735
5736 Names prefixed with "standard__" are handled specially:
5737 "standard__" is first stripped off (by the lookup_name
5738 constructor), and only static and global symbols are searched.
5739
5740 If MADE_GLOBAL_LOOKUP_P is non-null, set it before return to whether we had
5741 to lookup global symbols. */
5742
5743 static void
5744 ada_add_all_symbols (struct obstack *obstackp,
5745 const struct block *block,
5746 const lookup_name_info &lookup_name,
5747 domain_enum domain,
5748 int full_search,
5749 int *made_global_lookup_p)
5750 {
5751 struct symbol *sym;
5752
5753 if (made_global_lookup_p)
5754 *made_global_lookup_p = 0;
5755
5756 /* Special case: If the user specifies a symbol name inside package
5757 Standard, do a non-wild matching of the symbol name without
5758 the "standard__" prefix. This was primarily introduced in order
5759 to allow the user to specifically access the standard exceptions
5760 using, for instance, Standard.Constraint_Error when Constraint_Error
5761 is ambiguous (due to the user defining its own Constraint_Error
5762 entity inside its program). */
5763 if (lookup_name.ada ().standard_p ())
5764 block = NULL;
5765
5766 /* Check the non-global symbols. If we have ANY match, then we're done. */
5767
5768 if (block != NULL)
5769 {
5770 if (full_search)
5771 ada_add_local_symbols (obstackp, lookup_name, block, domain);
5772 else
5773 {
5774 /* In the !full_search case we're are being called by
5775 ada_iterate_over_symbols, and we don't want to search
5776 superblocks. */
5777 ada_add_block_symbols (obstackp, block, lookup_name, domain, NULL);
5778 }
5779 if (num_defns_collected (obstackp) > 0 || !full_search)
5780 return;
5781 }
5782
5783 /* No non-global symbols found. Check our cache to see if we have
5784 already performed this search before. If we have, then return
5785 the same result. */
5786
5787 if (lookup_cached_symbol (ada_lookup_name (lookup_name),
5788 domain, &sym, &block))
5789 {
5790 if (sym != NULL)
5791 add_defn_to_vec (obstackp, sym, block);
5792 return;
5793 }
5794
5795 if (made_global_lookup_p)
5796 *made_global_lookup_p = 1;
5797
5798 /* Search symbols from all global blocks. */
5799
5800 add_nonlocal_symbols (obstackp, lookup_name, domain, 1);
5801
5802 /* Now add symbols from all per-file blocks if we've gotten no hits
5803 (not strictly correct, but perhaps better than an error). */
5804
5805 if (num_defns_collected (obstackp) == 0)
5806 add_nonlocal_symbols (obstackp, lookup_name, domain, 0);
5807 }
5808
5809 /* Find symbols in DOMAIN matching LOOKUP_NAME, in BLOCK and, if FULL_SEARCH
5810 is non-zero, enclosing scope and in global scopes, returning the number of
5811 matches.
5812 Sets *RESULTS to point to a newly allocated vector of (SYM,BLOCK) tuples,
5813 indicating the symbols found and the blocks and symbol tables (if
5814 any) in which they were found. This vector should be freed when
5815 no longer useful.
5816
5817 When full_search is non-zero, any non-function/non-enumeral
5818 symbol match within the nest of blocks whose innermost member is BLOCK,
5819 is the one match returned (no other matches in that or
5820 enclosing blocks is returned). If there are any matches in or
5821 surrounding BLOCK, then these alone are returned.
5822
5823 Names prefixed with "standard__" are handled specially: "standard__"
5824 is first stripped off, and only static and global symbols are searched. */
5825
5826 static int
5827 ada_lookup_symbol_list_worker (const lookup_name_info &lookup_name,
5828 const struct block *block,
5829 domain_enum domain,
5830 struct block_symbol **results,
5831 int full_search)
5832 {
5833 int syms_from_global_search;
5834 int ndefns;
5835 int results_size;
5836 auto_obstack obstack;
5837
5838 ada_add_all_symbols (&obstack, block, lookup_name,
5839 domain, full_search, &syms_from_global_search);
5840
5841 ndefns = num_defns_collected (&obstack);
5842
5843 results_size = obstack_object_size (&obstack);
5844 *results = (struct block_symbol *) malloc (results_size);
5845 memcpy (*results, defns_collected (&obstack, 1), results_size);
5846
5847 ndefns = remove_extra_symbols (*results, ndefns);
5848
5849 if (ndefns == 0 && full_search && syms_from_global_search)
5850 cache_symbol (ada_lookup_name (lookup_name), domain, NULL, NULL);
5851
5852 if (ndefns == 1 && full_search && syms_from_global_search)
5853 cache_symbol (ada_lookup_name (lookup_name), domain,
5854 (*results)[0].symbol, (*results)[0].block);
5855
5856 ndefns = remove_irrelevant_renamings (*results, ndefns, block);
5857
5858 return ndefns;
5859 }
5860
5861 /* Find symbols in DOMAIN matching NAME, in BLOCK and enclosing scope and
5862 in global scopes, returning the number of matches, and setting *RESULTS
5863 to a newly-allocated vector of (SYM,BLOCK) tuples. This newly-allocated
5864 vector should be freed when no longer useful.
5865
5866 See ada_lookup_symbol_list_worker for further details. */
5867
5868 int
5869 ada_lookup_symbol_list (const char *name, const struct block *block,
5870 domain_enum domain, struct block_symbol **results)
5871 {
5872 symbol_name_match_type name_match_type = name_match_type_from_name (name);
5873 lookup_name_info lookup_name (name, name_match_type);
5874
5875 return ada_lookup_symbol_list_worker (lookup_name, block, domain, results, 1);
5876 }
5877
5878 /* Implementation of the la_iterate_over_symbols method. */
5879
5880 static void
5881 ada_iterate_over_symbols
5882 (const struct block *block, const lookup_name_info &name,
5883 domain_enum domain,
5884 gdb::function_view<symbol_found_callback_ftype> callback)
5885 {
5886 int ndefs, i;
5887 struct block_symbol *results;
5888 struct cleanup *old_chain;
5889
5890 ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5891 old_chain = make_cleanup (xfree, results);
5892
5893 for (i = 0; i < ndefs; ++i)
5894 {
5895 if (!callback (results[i].symbol))
5896 break;
5897 }
5898
5899 do_cleanups (old_chain);
5900 }
5901
5902 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5903 to 1, but choosing the first symbol found if there are multiple
5904 choices.
5905
5906 The result is stored in *INFO, which must be non-NULL.
5907 If no match is found, INFO->SYM is set to NULL. */
5908
5909 void
5910 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5911 domain_enum domain,
5912 struct block_symbol *info)
5913 {
5914 /* Since we already have an encoded name, wrap it in '<>' to force a
5915 verbatim match. Otherwise, if the name happens to not look like
5916 an encoded name (because it doesn't include a "__"),
5917 ada_lookup_name_info would re-encode/fold it again, and that
5918 would e.g., incorrectly lowercase object renaming names like
5919 "R28b" -> "r28b". */
5920 std::string verbatim = std::string ("<") + name + '>';
5921
5922 gdb_assert (info != NULL);
5923 *info = ada_lookup_symbol (verbatim.c_str (), block, domain, NULL);
5924 }
5925
5926 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5927 scope and in global scopes, or NULL if none. NAME is folded and
5928 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5929 choosing the first symbol if there are multiple choices.
5930 If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5931
5932 struct block_symbol
5933 ada_lookup_symbol (const char *name, const struct block *block0,
5934 domain_enum domain, int *is_a_field_of_this)
5935 {
5936 if (is_a_field_of_this != NULL)
5937 *is_a_field_of_this = 0;
5938
5939 struct block_symbol *candidates;
5940 int n_candidates;
5941 struct cleanup *old_chain;
5942
5943 n_candidates = ada_lookup_symbol_list (name, block0, domain, &candidates);
5944 old_chain = make_cleanup (xfree, candidates);
5945
5946 if (n_candidates == 0)
5947 {
5948 do_cleanups (old_chain);
5949 return {};
5950 }
5951
5952 block_symbol info = candidates[0];
5953 info.symbol = fixup_symbol_section (info.symbol, NULL);
5954
5955 do_cleanups (old_chain);
5956
5957 return info;
5958 }
5959
5960 static struct block_symbol
5961 ada_lookup_symbol_nonlocal (const struct language_defn *langdef,
5962 const char *name,
5963 const struct block *block,
5964 const domain_enum domain)
5965 {
5966 struct block_symbol sym;
5967
5968 sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
5969 if (sym.symbol != NULL)
5970 return sym;
5971
5972 /* If we haven't found a match at this point, try the primitive
5973 types. In other languages, this search is performed before
5974 searching for global symbols in order to short-circuit that
5975 global-symbol search if it happens that the name corresponds
5976 to a primitive type. But we cannot do the same in Ada, because
5977 it is perfectly legitimate for a program to declare a type which
5978 has the same name as a standard type. If looking up a type in
5979 that situation, we have traditionally ignored the primitive type
5980 in favor of user-defined types. This is why, unlike most other
5981 languages, we search the primitive types this late and only after
5982 having searched the global symbols without success. */
5983
5984 if (domain == VAR_DOMAIN)
5985 {
5986 struct gdbarch *gdbarch;
5987
5988 if (block == NULL)
5989 gdbarch = target_gdbarch ();
5990 else
5991 gdbarch = block_gdbarch (block);
5992 sym.symbol = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5993 if (sym.symbol != NULL)
5994 return sym;
5995 }
5996
5997 return (struct block_symbol) {NULL, NULL};
5998 }
5999
6000
6001 /* True iff STR is a possible encoded suffix of a normal Ada name
6002 that is to be ignored for matching purposes. Suffixes of parallel
6003 names (e.g., XVE) are not included here. Currently, the possible suffixes
6004 are given by any of the regular expressions:
6005
6006 [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
6007 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
6008 TKB [subprogram suffix for task bodies]
6009 _E[0-9]+[bs]$ [protected object entry suffixes]
6010 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
6011
6012 Also, any leading "__[0-9]+" sequence is skipped before the suffix
6013 match is performed. This sequence is used to differentiate homonyms,
6014 is an optional part of a valid name suffix. */
6015
6016 static int
6017 is_name_suffix (const char *str)
6018 {
6019 int k;
6020 const char *matching;
6021 const int len = strlen (str);
6022
6023 /* Skip optional leading __[0-9]+. */
6024
6025 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
6026 {
6027 str += 3;
6028 while (isdigit (str[0]))
6029 str += 1;
6030 }
6031
6032 /* [.$][0-9]+ */
6033
6034 if (str[0] == '.' || str[0] == '$')
6035 {
6036 matching = str + 1;
6037 while (isdigit (matching[0]))
6038 matching += 1;
6039 if (matching[0] == '\0')
6040 return 1;
6041 }
6042
6043 /* ___[0-9]+ */
6044
6045 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
6046 {
6047 matching = str + 3;
6048 while (isdigit (matching[0]))
6049 matching += 1;
6050 if (matching[0] == '\0')
6051 return 1;
6052 }
6053
6054 /* "TKB" suffixes are used for subprograms implementing task bodies. */
6055
6056 if (strcmp (str, "TKB") == 0)
6057 return 1;
6058
6059 #if 0
6060 /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
6061 with a N at the end. Unfortunately, the compiler uses the same
6062 convention for other internal types it creates. So treating
6063 all entity names that end with an "N" as a name suffix causes
6064 some regressions. For instance, consider the case of an enumerated
6065 type. To support the 'Image attribute, it creates an array whose
6066 name ends with N.
6067 Having a single character like this as a suffix carrying some
6068 information is a bit risky. Perhaps we should change the encoding
6069 to be something like "_N" instead. In the meantime, do not do
6070 the following check. */
6071 /* Protected Object Subprograms */
6072 if (len == 1 && str [0] == 'N')
6073 return 1;
6074 #endif
6075
6076 /* _E[0-9]+[bs]$ */
6077 if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
6078 {
6079 matching = str + 3;
6080 while (isdigit (matching[0]))
6081 matching += 1;
6082 if ((matching[0] == 'b' || matching[0] == 's')
6083 && matching [1] == '\0')
6084 return 1;
6085 }
6086
6087 /* ??? We should not modify STR directly, as we are doing below. This
6088 is fine in this case, but may become problematic later if we find
6089 that this alternative did not work, and want to try matching
6090 another one from the begining of STR. Since we modified it, we
6091 won't be able to find the begining of the string anymore! */
6092 if (str[0] == 'X')
6093 {
6094 str += 1;
6095 while (str[0] != '_' && str[0] != '\0')
6096 {
6097 if (str[0] != 'n' && str[0] != 'b')
6098 return 0;
6099 str += 1;
6100 }
6101 }
6102
6103 if (str[0] == '\000')
6104 return 1;
6105
6106 if (str[0] == '_')
6107 {
6108 if (str[1] != '_' || str[2] == '\000')
6109 return 0;
6110 if (str[2] == '_')
6111 {
6112 if (strcmp (str + 3, "JM") == 0)
6113 return 1;
6114 /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
6115 the LJM suffix in favor of the JM one. But we will
6116 still accept LJM as a valid suffix for a reasonable
6117 amount of time, just to allow ourselves to debug programs
6118 compiled using an older version of GNAT. */
6119 if (strcmp (str + 3, "LJM") == 0)
6120 return 1;
6121 if (str[3] != 'X')
6122 return 0;
6123 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
6124 || str[4] == 'U' || str[4] == 'P')
6125 return 1;
6126 if (str[4] == 'R' && str[5] != 'T')
6127 return 1;
6128 return 0;
6129 }
6130 if (!isdigit (str[2]))
6131 return 0;
6132 for (k = 3; str[k] != '\0'; k += 1)
6133 if (!isdigit (str[k]) && str[k] != '_')
6134 return 0;
6135 return 1;
6136 }
6137 if (str[0] == '$' && isdigit (str[1]))
6138 {
6139 for (k = 2; str[k] != '\0'; k += 1)
6140 if (!isdigit (str[k]) && str[k] != '_')
6141 return 0;
6142 return 1;
6143 }
6144 return 0;
6145 }
6146
6147 /* Return non-zero if the string starting at NAME and ending before
6148 NAME_END contains no capital letters. */
6149
6150 static int
6151 is_valid_name_for_wild_match (const char *name0)
6152 {
6153 const char *decoded_name = ada_decode (name0);
6154 int i;
6155
6156 /* If the decoded name starts with an angle bracket, it means that
6157 NAME0 does not follow the GNAT encoding format. It should then
6158 not be allowed as a possible wild match. */
6159 if (decoded_name[0] == '<')
6160 return 0;
6161
6162 for (i=0; decoded_name[i] != '\0'; i++)
6163 if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
6164 return 0;
6165
6166 return 1;
6167 }
6168
6169 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
6170 that could start a simple name. Assumes that *NAMEP points into
6171 the string beginning at NAME0. */
6172
6173 static int
6174 advance_wild_match (const char **namep, const char *name0, int target0)
6175 {
6176 const char *name = *namep;
6177
6178 while (1)
6179 {
6180 int t0, t1;
6181
6182 t0 = *name;
6183 if (t0 == '_')
6184 {
6185 t1 = name[1];
6186 if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
6187 {
6188 name += 1;
6189 if (name == name0 + 5 && startswith (name0, "_ada"))
6190 break;
6191 else
6192 name += 1;
6193 }
6194 else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
6195 || name[2] == target0))
6196 {
6197 name += 2;
6198 break;
6199 }
6200 else
6201 return 0;
6202 }
6203 else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
6204 name += 1;
6205 else
6206 return 0;
6207 }
6208
6209 *namep = name;
6210 return 1;
6211 }
6212
6213 /* Return true iff NAME encodes a name of the form prefix.PATN.
6214 Ignores any informational suffixes of NAME (i.e., for which
6215 is_name_suffix is true). Assumes that PATN is a lower-cased Ada
6216 simple name. */
6217
6218 static bool
6219 wild_match (const char *name, const char *patn)
6220 {
6221 const char *p;
6222 const char *name0 = name;
6223
6224 while (1)
6225 {
6226 const char *match = name;
6227
6228 if (*name == *patn)
6229 {
6230 for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
6231 if (*p != *name)
6232 break;
6233 if (*p == '\0' && is_name_suffix (name))
6234 return match == name0 || is_valid_name_for_wild_match (name0);
6235
6236 if (name[-1] == '_')
6237 name -= 1;
6238 }
6239 if (!advance_wild_match (&name, name0, *patn))
6240 return false;
6241 }
6242 }
6243
6244 /* Returns true iff symbol name SYM_NAME matches SEARCH_NAME, ignoring
6245 any trailing suffixes that encode debugging information or leading
6246 _ada_ on SYM_NAME (see is_name_suffix commentary for the debugging
6247 information that is ignored). */
6248
6249 static bool
6250 full_match (const char *sym_name, const char *search_name)
6251 {
6252 size_t search_name_len = strlen (search_name);
6253
6254 if (strncmp (sym_name, search_name, search_name_len) == 0
6255 && is_name_suffix (sym_name + search_name_len))
6256 return true;
6257
6258 if (startswith (sym_name, "_ada_")
6259 && strncmp (sym_name + 5, search_name, search_name_len) == 0
6260 && is_name_suffix (sym_name + search_name_len + 5))
6261 return true;
6262
6263 return false;
6264 }
6265
6266 /* Add symbols from BLOCK matching LOOKUP_NAME in DOMAIN to vector
6267 *defn_symbols, updating the list of symbols in OBSTACKP (if
6268 necessary). OBJFILE is the section containing BLOCK. */
6269
6270 static void
6271 ada_add_block_symbols (struct obstack *obstackp,
6272 const struct block *block,
6273 const lookup_name_info &lookup_name,
6274 domain_enum domain, struct objfile *objfile)
6275 {
6276 struct block_iterator iter;
6277 /* A matching argument symbol, if any. */
6278 struct symbol *arg_sym;
6279 /* Set true when we find a matching non-argument symbol. */
6280 int found_sym;
6281 struct symbol *sym;
6282
6283 arg_sym = NULL;
6284 found_sym = 0;
6285 for (sym = block_iter_match_first (block, lookup_name, &iter);
6286 sym != NULL;
6287 sym = block_iter_match_next (lookup_name, &iter))
6288 {
6289 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6290 SYMBOL_DOMAIN (sym), domain))
6291 {
6292 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6293 {
6294 if (SYMBOL_IS_ARGUMENT (sym))
6295 arg_sym = sym;
6296 else
6297 {
6298 found_sym = 1;
6299 add_defn_to_vec (obstackp,
6300 fixup_symbol_section (sym, objfile),
6301 block);
6302 }
6303 }
6304 }
6305 }
6306
6307 /* Handle renamings. */
6308
6309 if (ada_add_block_renamings (obstackp, block, lookup_name, domain))
6310 found_sym = 1;
6311
6312 if (!found_sym && arg_sym != NULL)
6313 {
6314 add_defn_to_vec (obstackp,
6315 fixup_symbol_section (arg_sym, objfile),
6316 block);
6317 }
6318
6319 if (!lookup_name.ada ().wild_match_p ())
6320 {
6321 arg_sym = NULL;
6322 found_sym = 0;
6323 const std::string &ada_lookup_name = lookup_name.ada ().lookup_name ();
6324 const char *name = ada_lookup_name.c_str ();
6325 size_t name_len = ada_lookup_name.size ();
6326
6327 ALL_BLOCK_SYMBOLS (block, iter, sym)
6328 {
6329 if (symbol_matches_domain (SYMBOL_LANGUAGE (sym),
6330 SYMBOL_DOMAIN (sym), domain))
6331 {
6332 int cmp;
6333
6334 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6335 if (cmp == 0)
6336 {
6337 cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
6338 if (cmp == 0)
6339 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6340 name_len);
6341 }
6342
6343 if (cmp == 0
6344 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6345 {
6346 if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6347 {
6348 if (SYMBOL_IS_ARGUMENT (sym))
6349 arg_sym = sym;
6350 else
6351 {
6352 found_sym = 1;
6353 add_defn_to_vec (obstackp,
6354 fixup_symbol_section (sym, objfile),
6355 block);
6356 }
6357 }
6358 }
6359 }
6360 }
6361
6362 /* NOTE: This really shouldn't be needed for _ada_ symbols.
6363 They aren't parameters, right? */
6364 if (!found_sym && arg_sym != NULL)
6365 {
6366 add_defn_to_vec (obstackp,
6367 fixup_symbol_section (arg_sym, objfile),
6368 block);
6369 }
6370 }
6371 }
6372
6373
6374 /* Symbol Completion */
6375
6376 /* See symtab.h. */
6377
6378 bool
6379 ada_lookup_name_info::matches
6380 (const char *sym_name,
6381 symbol_name_match_type match_type,
6382 completion_match_result *comp_match_res) const
6383 {
6384 bool match = false;
6385 const char *text = m_encoded_name.c_str ();
6386 size_t text_len = m_encoded_name.size ();
6387
6388 /* First, test against the fully qualified name of the symbol. */
6389
6390 if (strncmp (sym_name, text, text_len) == 0)
6391 match = true;
6392
6393 if (match && !m_encoded_p)
6394 {
6395 /* One needed check before declaring a positive match is to verify
6396 that iff we are doing a verbatim match, the decoded version
6397 of the symbol name starts with '<'. Otherwise, this symbol name
6398 is not a suitable completion. */
6399 const char *sym_name_copy = sym_name;
6400 bool has_angle_bracket;
6401
6402 sym_name = ada_decode (sym_name);
6403 has_angle_bracket = (sym_name[0] == '<');
6404 match = (has_angle_bracket == m_verbatim_p);
6405 sym_name = sym_name_copy;
6406 }
6407
6408 if (match && !m_verbatim_p)
6409 {
6410 /* When doing non-verbatim match, another check that needs to
6411 be done is to verify that the potentially matching symbol name
6412 does not include capital letters, because the ada-mode would
6413 not be able to understand these symbol names without the
6414 angle bracket notation. */
6415 const char *tmp;
6416
6417 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6418 if (*tmp != '\0')
6419 match = false;
6420 }
6421
6422 /* Second: Try wild matching... */
6423
6424 if (!match && m_wild_match_p)
6425 {
6426 /* Since we are doing wild matching, this means that TEXT
6427 may represent an unqualified symbol name. We therefore must
6428 also compare TEXT against the unqualified name of the symbol. */
6429 sym_name = ada_unqualified_name (ada_decode (sym_name));
6430
6431 if (strncmp (sym_name, text, text_len) == 0)
6432 match = true;
6433 }
6434
6435 /* Finally: If we found a match, prepare the result to return. */
6436
6437 if (!match)
6438 return false;
6439
6440 if (comp_match_res != NULL)
6441 {
6442 std::string &match_str = comp_match_res->match.storage ();
6443
6444 if (!m_encoded_p)
6445 match_str = ada_decode (sym_name);
6446 else
6447 {
6448 if (m_verbatim_p)
6449 match_str = add_angle_brackets (sym_name);
6450 else
6451 match_str = sym_name;
6452
6453 }
6454
6455 comp_match_res->set_match (match_str.c_str ());
6456 }
6457
6458 return true;
6459 }
6460
6461 /* Add the list of possible symbol names completing TEXT to TRACKER.
6462 WORD is the entire command on which completion is made. */
6463
6464 static void
6465 ada_collect_symbol_completion_matches (completion_tracker &tracker,
6466 complete_symbol_mode mode,
6467 symbol_name_match_type name_match_type,
6468 const char *text, const char *word,
6469 enum type_code code)
6470 {
6471 struct symbol *sym;
6472 struct compunit_symtab *s;
6473 struct minimal_symbol *msymbol;
6474 struct objfile *objfile;
6475 const struct block *b, *surrounding_static_block = 0;
6476 struct block_iterator iter;
6477 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
6478
6479 gdb_assert (code == TYPE_CODE_UNDEF);
6480
6481 lookup_name_info lookup_name (text, name_match_type, true);
6482
6483 /* First, look at the partial symtab symbols. */
6484 expand_symtabs_matching (NULL,
6485 lookup_name,
6486 NULL,
6487 NULL,
6488 ALL_DOMAIN);
6489
6490 /* At this point scan through the misc symbol vectors and add each
6491 symbol you find to the list. Eventually we want to ignore
6492 anything that isn't a text symbol (everything else will be
6493 handled by the psymtab code above). */
6494
6495 ALL_MSYMBOLS (objfile, msymbol)
6496 {
6497 QUIT;
6498
6499 if (completion_skip_symbol (mode, msymbol))
6500 continue;
6501
6502 language symbol_language = MSYMBOL_LANGUAGE (msymbol);
6503
6504 /* Ada minimal symbols won't have their language set to Ada. If
6505 we let completion_list_add_name compare using the
6506 default/C-like matcher, then when completing e.g., symbols in a
6507 package named "pck", we'd match internal Ada symbols like
6508 "pckS", which are invalid in an Ada expression, unless you wrap
6509 them in '<' '>' to request a verbatim match.
6510
6511 Unfortunately, some Ada encoded names successfully demangle as
6512 C++ symbols (using an old mangling scheme), such as "name__2Xn"
6513 -> "Xn::name(void)" and thus some Ada minimal symbols end up
6514 with the wrong language set. Paper over that issue here. */
6515 if (symbol_language == language_auto
6516 || symbol_language == language_cplus)
6517 symbol_language = language_ada;
6518
6519 completion_list_add_name (tracker,
6520 symbol_language,
6521 MSYMBOL_LINKAGE_NAME (msymbol),
6522 lookup_name, text, word);
6523 }
6524
6525 /* Search upwards from currently selected frame (so that we can
6526 complete on local vars. */
6527
6528 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6529 {
6530 if (!BLOCK_SUPERBLOCK (b))
6531 surrounding_static_block = b; /* For elmin of dups */
6532
6533 ALL_BLOCK_SYMBOLS (b, iter, sym)
6534 {
6535 if (completion_skip_symbol (mode, sym))
6536 continue;
6537
6538 completion_list_add_name (tracker,
6539 SYMBOL_LANGUAGE (sym),
6540 SYMBOL_LINKAGE_NAME (sym),
6541 lookup_name, text, word);
6542 }
6543 }
6544
6545 /* Go through the symtabs and check the externs and statics for
6546 symbols which match. */
6547
6548 ALL_COMPUNITS (objfile, s)
6549 {
6550 QUIT;
6551 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), GLOBAL_BLOCK);
6552 ALL_BLOCK_SYMBOLS (b, iter, sym)
6553 {
6554 if (completion_skip_symbol (mode, sym))
6555 continue;
6556
6557 completion_list_add_name (tracker,
6558 SYMBOL_LANGUAGE (sym),
6559 SYMBOL_LINKAGE_NAME (sym),
6560 lookup_name, text, word);
6561 }
6562 }
6563
6564 ALL_COMPUNITS (objfile, s)
6565 {
6566 QUIT;
6567 b = BLOCKVECTOR_BLOCK (COMPUNIT_BLOCKVECTOR (s), STATIC_BLOCK);
6568 /* Don't do this block twice. */
6569 if (b == surrounding_static_block)
6570 continue;
6571 ALL_BLOCK_SYMBOLS (b, iter, sym)
6572 {
6573 if (completion_skip_symbol (mode, sym))
6574 continue;
6575
6576 completion_list_add_name (tracker,
6577 SYMBOL_LANGUAGE (sym),
6578 SYMBOL_LINKAGE_NAME (sym),
6579 lookup_name, text, word);
6580 }
6581 }
6582
6583 do_cleanups (old_chain);
6584 }
6585
6586 /* Field Access */
6587
6588 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6589 for tagged types. */
6590
6591 static int
6592 ada_is_dispatch_table_ptr_type (struct type *type)
6593 {
6594 const char *name;
6595
6596 if (TYPE_CODE (type) != TYPE_CODE_PTR)
6597 return 0;
6598
6599 name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6600 if (name == NULL)
6601 return 0;
6602
6603 return (strcmp (name, "ada__tags__dispatch_table") == 0);
6604 }
6605
6606 /* Return non-zero if TYPE is an interface tag. */
6607
6608 static int
6609 ada_is_interface_tag (struct type *type)
6610 {
6611 const char *name = TYPE_NAME (type);
6612
6613 if (name == NULL)
6614 return 0;
6615
6616 return (strcmp (name, "ada__tags__interface_tag") == 0);
6617 }
6618
6619 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6620 to be invisible to users. */
6621
6622 int
6623 ada_is_ignored_field (struct type *type, int field_num)
6624 {
6625 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6626 return 1;
6627
6628 /* Check the name of that field. */
6629 {
6630 const char *name = TYPE_FIELD_NAME (type, field_num);
6631
6632 /* Anonymous field names should not be printed.
6633 brobecker/2007-02-20: I don't think this can actually happen
6634 but we don't want to print the value of annonymous fields anyway. */
6635 if (name == NULL)
6636 return 1;
6637
6638 /* Normally, fields whose name start with an underscore ("_")
6639 are fields that have been internally generated by the compiler,
6640 and thus should not be printed. The "_parent" field is special,
6641 however: This is a field internally generated by the compiler
6642 for tagged types, and it contains the components inherited from
6643 the parent type. This field should not be printed as is, but
6644 should not be ignored either. */
6645 if (name[0] == '_' && !startswith (name, "_parent"))
6646 return 1;
6647 }
6648
6649 /* If this is the dispatch table of a tagged type or an interface tag,
6650 then ignore. */
6651 if (ada_is_tagged_type (type, 1)
6652 && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6653 || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6654 return 1;
6655
6656 /* Not a special field, so it should not be ignored. */
6657 return 0;
6658 }
6659
6660 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6661 pointer or reference type whose ultimate target has a tag field. */
6662
6663 int
6664 ada_is_tagged_type (struct type *type, int refok)
6665 {
6666 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1) != NULL);
6667 }
6668
6669 /* True iff TYPE represents the type of X'Tag */
6670
6671 int
6672 ada_is_tag_type (struct type *type)
6673 {
6674 type = ada_check_typedef (type);
6675
6676 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6677 return 0;
6678 else
6679 {
6680 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6681
6682 return (name != NULL
6683 && strcmp (name, "ada__tags__dispatch_table") == 0);
6684 }
6685 }
6686
6687 /* The type of the tag on VAL. */
6688
6689 struct type *
6690 ada_tag_type (struct value *val)
6691 {
6692 return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0);
6693 }
6694
6695 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6696 retired at Ada 05). */
6697
6698 static int
6699 is_ada95_tag (struct value *tag)
6700 {
6701 return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6702 }
6703
6704 /* The value of the tag on VAL. */
6705
6706 struct value *
6707 ada_value_tag (struct value *val)
6708 {
6709 return ada_value_struct_elt (val, "_tag", 0);
6710 }
6711
6712 /* The value of the tag on the object of type TYPE whose contents are
6713 saved at VALADDR, if it is non-null, or is at memory address
6714 ADDRESS. */
6715
6716 static struct value *
6717 value_tag_from_contents_and_address (struct type *type,
6718 const gdb_byte *valaddr,
6719 CORE_ADDR address)
6720 {
6721 int tag_byte_offset;
6722 struct type *tag_type;
6723
6724 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6725 NULL, NULL, NULL))
6726 {
6727 const gdb_byte *valaddr1 = ((valaddr == NULL)
6728 ? NULL
6729 : valaddr + tag_byte_offset);
6730 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6731
6732 return value_from_contents_and_address (tag_type, valaddr1, address1);
6733 }
6734 return NULL;
6735 }
6736
6737 static struct type *
6738 type_from_tag (struct value *tag)
6739 {
6740 const char *type_name = ada_tag_name (tag);
6741
6742 if (type_name != NULL)
6743 return ada_find_any_type (ada_encode (type_name));
6744 return NULL;
6745 }
6746
6747 /* Given a value OBJ of a tagged type, return a value of this
6748 type at the base address of the object. The base address, as
6749 defined in Ada.Tags, it is the address of the primary tag of
6750 the object, and therefore where the field values of its full
6751 view can be fetched. */
6752
6753 struct value *
6754 ada_tag_value_at_base_address (struct value *obj)
6755 {
6756 struct value *val;
6757 LONGEST offset_to_top = 0;
6758 struct type *ptr_type, *obj_type;
6759 struct value *tag;
6760 CORE_ADDR base_address;
6761
6762 obj_type = value_type (obj);
6763
6764 /* It is the responsability of the caller to deref pointers. */
6765
6766 if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6767 || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6768 return obj;
6769
6770 tag = ada_value_tag (obj);
6771 if (!tag)
6772 return obj;
6773
6774 /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6775
6776 if (is_ada95_tag (tag))
6777 return obj;
6778
6779 ptr_type = language_lookup_primitive_type
6780 (language_def (language_ada), target_gdbarch(), "storage_offset");
6781 ptr_type = lookup_pointer_type (ptr_type);
6782 val = value_cast (ptr_type, tag);
6783 if (!val)
6784 return obj;
6785
6786 /* It is perfectly possible that an exception be raised while
6787 trying to determine the base address, just like for the tag;
6788 see ada_tag_name for more details. We do not print the error
6789 message for the same reason. */
6790
6791 TRY
6792 {
6793 offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6794 }
6795
6796 CATCH (e, RETURN_MASK_ERROR)
6797 {
6798 return obj;
6799 }
6800 END_CATCH
6801
6802 /* If offset is null, nothing to do. */
6803
6804 if (offset_to_top == 0)
6805 return obj;
6806
6807 /* -1 is a special case in Ada.Tags; however, what should be done
6808 is not quite clear from the documentation. So do nothing for
6809 now. */
6810
6811 if (offset_to_top == -1)
6812 return obj;
6813
6814 /* OFFSET_TO_TOP used to be a positive value to be subtracted
6815 from the base address. This was however incompatible with
6816 C++ dispatch table: C++ uses a *negative* value to *add*
6817 to the base address. Ada's convention has therefore been
6818 changed in GNAT 19.0w 20171023: since then, C++ and Ada
6819 use the same convention. Here, we support both cases by
6820 checking the sign of OFFSET_TO_TOP. */
6821
6822 if (offset_to_top > 0)
6823 offset_to_top = -offset_to_top;
6824
6825 base_address = value_address (obj) + offset_to_top;
6826 tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6827
6828 /* Make sure that we have a proper tag at the new address.
6829 Otherwise, offset_to_top is bogus (which can happen when
6830 the object is not initialized yet). */
6831
6832 if (!tag)
6833 return obj;
6834
6835 obj_type = type_from_tag (tag);
6836
6837 if (!obj_type)
6838 return obj;
6839
6840 return value_from_contents_and_address (obj_type, NULL, base_address);
6841 }
6842
6843 /* Return the "ada__tags__type_specific_data" type. */
6844
6845 static struct type *
6846 ada_get_tsd_type (struct inferior *inf)
6847 {
6848 struct ada_inferior_data *data = get_ada_inferior_data (inf);
6849
6850 if (data->tsd_type == 0)
6851 data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6852 return data->tsd_type;
6853 }
6854
6855 /* Return the TSD (type-specific data) associated to the given TAG.
6856 TAG is assumed to be the tag of a tagged-type entity.
6857
6858 May return NULL if we are unable to get the TSD. */
6859
6860 static struct value *
6861 ada_get_tsd_from_tag (struct value *tag)
6862 {
6863 struct value *val;
6864 struct type *type;
6865
6866 /* First option: The TSD is simply stored as a field of our TAG.
6867 Only older versions of GNAT would use this format, but we have
6868 to test it first, because there are no visible markers for
6869 the current approach except the absence of that field. */
6870
6871 val = ada_value_struct_elt (tag, "tsd", 1);
6872 if (val)
6873 return val;
6874
6875 /* Try the second representation for the dispatch table (in which
6876 there is no explicit 'tsd' field in the referent of the tag pointer,
6877 and instead the tsd pointer is stored just before the dispatch
6878 table. */
6879
6880 type = ada_get_tsd_type (current_inferior());
6881 if (type == NULL)
6882 return NULL;
6883 type = lookup_pointer_type (lookup_pointer_type (type));
6884 val = value_cast (type, tag);
6885 if (val == NULL)
6886 return NULL;
6887 return value_ind (value_ptradd (val, -1));
6888 }
6889
6890 /* Given the TSD of a tag (type-specific data), return a string
6891 containing the name of the associated type.
6892
6893 The returned value is good until the next call. May return NULL
6894 if we are unable to determine the tag name. */
6895
6896 static char *
6897 ada_tag_name_from_tsd (struct value *tsd)
6898 {
6899 static char name[1024];
6900 char *p;
6901 struct value *val;
6902
6903 val = ada_value_struct_elt (tsd, "expanded_name", 1);
6904 if (val == NULL)
6905 return NULL;
6906 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6907 for (p = name; *p != '\0'; p += 1)
6908 if (isalpha (*p))
6909 *p = tolower (*p);
6910 return name;
6911 }
6912
6913 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6914 a C string.
6915
6916 Return NULL if the TAG is not an Ada tag, or if we were unable to
6917 determine the name of that tag. The result is good until the next
6918 call. */
6919
6920 const char *
6921 ada_tag_name (struct value *tag)
6922 {
6923 char *name = NULL;
6924
6925 if (!ada_is_tag_type (value_type (tag)))
6926 return NULL;
6927
6928 /* It is perfectly possible that an exception be raised while trying
6929 to determine the TAG's name, even under normal circumstances:
6930 The associated variable may be uninitialized or corrupted, for
6931 instance. We do not let any exception propagate past this point.
6932 instead we return NULL.
6933
6934 We also do not print the error message either (which often is very
6935 low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6936 the caller print a more meaningful message if necessary. */
6937 TRY
6938 {
6939 struct value *tsd = ada_get_tsd_from_tag (tag);
6940
6941 if (tsd != NULL)
6942 name = ada_tag_name_from_tsd (tsd);
6943 }
6944 CATCH (e, RETURN_MASK_ERROR)
6945 {
6946 }
6947 END_CATCH
6948
6949 return name;
6950 }
6951
6952 /* The parent type of TYPE, or NULL if none. */
6953
6954 struct type *
6955 ada_parent_type (struct type *type)
6956 {
6957 int i;
6958
6959 type = ada_check_typedef (type);
6960
6961 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6962 return NULL;
6963
6964 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6965 if (ada_is_parent_field (type, i))
6966 {
6967 struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6968
6969 /* If the _parent field is a pointer, then dereference it. */
6970 if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6971 parent_type = TYPE_TARGET_TYPE (parent_type);
6972 /* If there is a parallel XVS type, get the actual base type. */
6973 parent_type = ada_get_base_type (parent_type);
6974
6975 return ada_check_typedef (parent_type);
6976 }
6977
6978 return NULL;
6979 }
6980
6981 /* True iff field number FIELD_NUM of structure type TYPE contains the
6982 parent-type (inherited) fields of a derived type. Assumes TYPE is
6983 a structure type with at least FIELD_NUM+1 fields. */
6984
6985 int
6986 ada_is_parent_field (struct type *type, int field_num)
6987 {
6988 const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6989
6990 return (name != NULL
6991 && (startswith (name, "PARENT")
6992 || startswith (name, "_parent")));
6993 }
6994
6995 /* True iff field number FIELD_NUM of structure type TYPE is a
6996 transparent wrapper field (which should be silently traversed when doing
6997 field selection and flattened when printing). Assumes TYPE is a
6998 structure type with at least FIELD_NUM+1 fields. Such fields are always
6999 structures. */
7000
7001 int
7002 ada_is_wrapper_field (struct type *type, int field_num)
7003 {
7004 const char *name = TYPE_FIELD_NAME (type, field_num);
7005
7006 if (name != NULL && strcmp (name, "RETVAL") == 0)
7007 {
7008 /* This happens in functions with "out" or "in out" parameters
7009 which are passed by copy. For such functions, GNAT describes
7010 the function's return type as being a struct where the return
7011 value is in a field called RETVAL, and where the other "out"
7012 or "in out" parameters are fields of that struct. This is not
7013 a wrapper. */
7014 return 0;
7015 }
7016
7017 return (name != NULL
7018 && (startswith (name, "PARENT")
7019 || strcmp (name, "REP") == 0
7020 || startswith (name, "_parent")
7021 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
7022 }
7023
7024 /* True iff field number FIELD_NUM of structure or union type TYPE
7025 is a variant wrapper. Assumes TYPE is a structure type with at least
7026 FIELD_NUM+1 fields. */
7027
7028 int
7029 ada_is_variant_part (struct type *type, int field_num)
7030 {
7031 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
7032
7033 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
7034 || (is_dynamic_field (type, field_num)
7035 && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
7036 == TYPE_CODE_UNION)));
7037 }
7038
7039 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
7040 whose discriminants are contained in the record type OUTER_TYPE,
7041 returns the type of the controlling discriminant for the variant.
7042 May return NULL if the type could not be found. */
7043
7044 struct type *
7045 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
7046 {
7047 const char *name = ada_variant_discrim_name (var_type);
7048
7049 return ada_lookup_struct_elt_type (outer_type, name, 1, 1);
7050 }
7051
7052 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
7053 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
7054 represents a 'when others' clause; otherwise 0. */
7055
7056 int
7057 ada_is_others_clause (struct type *type, int field_num)
7058 {
7059 const char *name = TYPE_FIELD_NAME (type, field_num);
7060
7061 return (name != NULL && name[0] == 'O');
7062 }
7063
7064 /* Assuming that TYPE0 is the type of the variant part of a record,
7065 returns the name of the discriminant controlling the variant.
7066 The value is valid until the next call to ada_variant_discrim_name. */
7067
7068 const char *
7069 ada_variant_discrim_name (struct type *type0)
7070 {
7071 static char *result = NULL;
7072 static size_t result_len = 0;
7073 struct type *type;
7074 const char *name;
7075 const char *discrim_end;
7076 const char *discrim_start;
7077
7078 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
7079 type = TYPE_TARGET_TYPE (type0);
7080 else
7081 type = type0;
7082
7083 name = ada_type_name (type);
7084
7085 if (name == NULL || name[0] == '\000')
7086 return "";
7087
7088 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
7089 discrim_end -= 1)
7090 {
7091 if (startswith (discrim_end, "___XVN"))
7092 break;
7093 }
7094 if (discrim_end == name)
7095 return "";
7096
7097 for (discrim_start = discrim_end; discrim_start != name + 3;
7098 discrim_start -= 1)
7099 {
7100 if (discrim_start == name + 1)
7101 return "";
7102 if ((discrim_start > name + 3
7103 && startswith (discrim_start - 3, "___"))
7104 || discrim_start[-1] == '.')
7105 break;
7106 }
7107
7108 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
7109 strncpy (result, discrim_start, discrim_end - discrim_start);
7110 result[discrim_end - discrim_start] = '\0';
7111 return result;
7112 }
7113
7114 /* Scan STR for a subtype-encoded number, beginning at position K.
7115 Put the position of the character just past the number scanned in
7116 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
7117 Return 1 if there was a valid number at the given position, and 0
7118 otherwise. A "subtype-encoded" number consists of the absolute value
7119 in decimal, followed by the letter 'm' to indicate a negative number.
7120 Assumes 0m does not occur. */
7121
7122 int
7123 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
7124 {
7125 ULONGEST RU;
7126
7127 if (!isdigit (str[k]))
7128 return 0;
7129
7130 /* Do it the hard way so as not to make any assumption about
7131 the relationship of unsigned long (%lu scan format code) and
7132 LONGEST. */
7133 RU = 0;
7134 while (isdigit (str[k]))
7135 {
7136 RU = RU * 10 + (str[k] - '0');
7137 k += 1;
7138 }
7139
7140 if (str[k] == 'm')
7141 {
7142 if (R != NULL)
7143 *R = (-(LONGEST) (RU - 1)) - 1;
7144 k += 1;
7145 }
7146 else if (R != NULL)
7147 *R = (LONGEST) RU;
7148
7149 /* NOTE on the above: Technically, C does not say what the results of
7150 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
7151 number representable as a LONGEST (although either would probably work
7152 in most implementations). When RU>0, the locution in the then branch
7153 above is always equivalent to the negative of RU. */
7154
7155 if (new_k != NULL)
7156 *new_k = k;
7157 return 1;
7158 }
7159
7160 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
7161 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
7162 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
7163
7164 int
7165 ada_in_variant (LONGEST val, struct type *type, int field_num)
7166 {
7167 const char *name = TYPE_FIELD_NAME (type, field_num);
7168 int p;
7169
7170 p = 0;
7171 while (1)
7172 {
7173 switch (name[p])
7174 {
7175 case '\0':
7176 return 0;
7177 case 'S':
7178 {
7179 LONGEST W;
7180
7181 if (!ada_scan_number (name, p + 1, &W, &p))
7182 return 0;
7183 if (val == W)
7184 return 1;
7185 break;
7186 }
7187 case 'R':
7188 {
7189 LONGEST L, U;
7190
7191 if (!ada_scan_number (name, p + 1, &L, &p)
7192 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
7193 return 0;
7194 if (val >= L && val <= U)
7195 return 1;
7196 break;
7197 }
7198 case 'O':
7199 return 1;
7200 default:
7201 return 0;
7202 }
7203 }
7204 }
7205
7206 /* FIXME: Lots of redundancy below. Try to consolidate. */
7207
7208 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
7209 ARG_TYPE, extract and return the value of one of its (non-static)
7210 fields. FIELDNO says which field. Differs from value_primitive_field
7211 only in that it can handle packed values of arbitrary type. */
7212
7213 static struct value *
7214 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
7215 struct type *arg_type)
7216 {
7217 struct type *type;
7218
7219 arg_type = ada_check_typedef (arg_type);
7220 type = TYPE_FIELD_TYPE (arg_type, fieldno);
7221
7222 /* Handle packed fields. */
7223
7224 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7225 {
7226 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7227 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
7228
7229 return ada_value_primitive_packed_val (arg1, value_contents (arg1),
7230 offset + bit_pos / 8,
7231 bit_pos % 8, bit_size, type);
7232 }
7233 else
7234 return value_primitive_field (arg1, offset, fieldno, arg_type);
7235 }
7236
7237 /* Find field with name NAME in object of type TYPE. If found,
7238 set the following for each argument that is non-null:
7239 - *FIELD_TYPE_P to the field's type;
7240 - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7241 an object of that type;
7242 - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7243 - *BIT_SIZE_P to its size in bits if the field is packed, and
7244 0 otherwise;
7245 If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7246 fields up to but not including the desired field, or by the total
7247 number of fields if not found. A NULL value of NAME never
7248 matches; the function just counts visible fields in this case.
7249
7250 Notice that we need to handle when a tagged record hierarchy
7251 has some components with the same name, like in this scenario:
7252
7253 type Top_T is tagged record
7254 N : Integer := 1;
7255 U : Integer := 974;
7256 A : Integer := 48;
7257 end record;
7258
7259 type Middle_T is new Top.Top_T with record
7260 N : Character := 'a';
7261 C : Integer := 3;
7262 end record;
7263
7264 type Bottom_T is new Middle.Middle_T with record
7265 N : Float := 4.0;
7266 C : Character := '5';
7267 X : Integer := 6;
7268 A : Character := 'J';
7269 end record;
7270
7271 Let's say we now have a variable declared and initialized as follow:
7272
7273 TC : Top_A := new Bottom_T;
7274
7275 And then we use this variable to call this function
7276
7277 procedure Assign (Obj: in out Top_T; TV : Integer);
7278
7279 as follow:
7280
7281 Assign (Top_T (B), 12);
7282
7283 Now, we're in the debugger, and we're inside that procedure
7284 then and we want to print the value of obj.c:
7285
7286 Usually, the tagged record or one of the parent type owns the
7287 component to print and there's no issue but in this particular
7288 case, what does it mean to ask for Obj.C? Since the actual
7289 type for object is type Bottom_T, it could mean two things: type
7290 component C from the Middle_T view, but also component C from
7291 Bottom_T. So in that "undefined" case, when the component is
7292 not found in the non-resolved type (which includes all the
7293 components of the parent type), then resolve it and see if we
7294 get better luck once expanded.
7295
7296 In the case of homonyms in the derived tagged type, we don't
7297 guaranty anything, and pick the one that's easiest for us
7298 to program.
7299
7300 Returns 1 if found, 0 otherwise. */
7301
7302 static int
7303 find_struct_field (const char *name, struct type *type, int offset,
7304 struct type **field_type_p,
7305 int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7306 int *index_p)
7307 {
7308 int i;
7309 int parent_offset = -1;
7310
7311 type = ada_check_typedef (type);
7312
7313 if (field_type_p != NULL)
7314 *field_type_p = NULL;
7315 if (byte_offset_p != NULL)
7316 *byte_offset_p = 0;
7317 if (bit_offset_p != NULL)
7318 *bit_offset_p = 0;
7319 if (bit_size_p != NULL)
7320 *bit_size_p = 0;
7321
7322 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7323 {
7324 int bit_pos = TYPE_FIELD_BITPOS (type, i);
7325 int fld_offset = offset + bit_pos / 8;
7326 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7327
7328 if (t_field_name == NULL)
7329 continue;
7330
7331 else if (ada_is_parent_field (type, i))
7332 {
7333 /* This is a field pointing us to the parent type of a tagged
7334 type. As hinted in this function's documentation, we give
7335 preference to fields in the current record first, so what
7336 we do here is just record the index of this field before
7337 we skip it. If it turns out we couldn't find our field
7338 in the current record, then we'll get back to it and search
7339 inside it whether the field might exist in the parent. */
7340
7341 parent_offset = i;
7342 continue;
7343 }
7344
7345 else if (name != NULL && field_name_match (t_field_name, name))
7346 {
7347 int bit_size = TYPE_FIELD_BITSIZE (type, i);
7348
7349 if (field_type_p != NULL)
7350 *field_type_p = TYPE_FIELD_TYPE (type, i);
7351 if (byte_offset_p != NULL)
7352 *byte_offset_p = fld_offset;
7353 if (bit_offset_p != NULL)
7354 *bit_offset_p = bit_pos % 8;
7355 if (bit_size_p != NULL)
7356 *bit_size_p = bit_size;
7357 return 1;
7358 }
7359 else if (ada_is_wrapper_field (type, i))
7360 {
7361 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7362 field_type_p, byte_offset_p, bit_offset_p,
7363 bit_size_p, index_p))
7364 return 1;
7365 }
7366 else if (ada_is_variant_part (type, i))
7367 {
7368 /* PNH: Wait. Do we ever execute this section, or is ARG always of
7369 fixed type?? */
7370 int j;
7371 struct type *field_type
7372 = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7373
7374 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7375 {
7376 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7377 fld_offset
7378 + TYPE_FIELD_BITPOS (field_type, j) / 8,
7379 field_type_p, byte_offset_p,
7380 bit_offset_p, bit_size_p, index_p))
7381 return 1;
7382 }
7383 }
7384 else if (index_p != NULL)
7385 *index_p += 1;
7386 }
7387
7388 /* Field not found so far. If this is a tagged type which
7389 has a parent, try finding that field in the parent now. */
7390
7391 if (parent_offset != -1)
7392 {
7393 int bit_pos = TYPE_FIELD_BITPOS (type, parent_offset);
7394 int fld_offset = offset + bit_pos / 8;
7395
7396 if (find_struct_field (name, TYPE_FIELD_TYPE (type, parent_offset),
7397 fld_offset, field_type_p, byte_offset_p,
7398 bit_offset_p, bit_size_p, index_p))
7399 return 1;
7400 }
7401
7402 return 0;
7403 }
7404
7405 /* Number of user-visible fields in record type TYPE. */
7406
7407 static int
7408 num_visible_fields (struct type *type)
7409 {
7410 int n;
7411
7412 n = 0;
7413 find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7414 return n;
7415 }
7416
7417 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7418 and search in it assuming it has (class) type TYPE.
7419 If found, return value, else return NULL.
7420
7421 Searches recursively through wrapper fields (e.g., '_parent').
7422
7423 In the case of homonyms in the tagged types, please refer to the
7424 long explanation in find_struct_field's function documentation. */
7425
7426 static struct value *
7427 ada_search_struct_field (const char *name, struct value *arg, int offset,
7428 struct type *type)
7429 {
7430 int i;
7431 int parent_offset = -1;
7432
7433 type = ada_check_typedef (type);
7434 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7435 {
7436 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7437
7438 if (t_field_name == NULL)
7439 continue;
7440
7441 else if (ada_is_parent_field (type, i))
7442 {
7443 /* This is a field pointing us to the parent type of a tagged
7444 type. As hinted in this function's documentation, we give
7445 preference to fields in the current record first, so what
7446 we do here is just record the index of this field before
7447 we skip it. If it turns out we couldn't find our field
7448 in the current record, then we'll get back to it and search
7449 inside it whether the field might exist in the parent. */
7450
7451 parent_offset = i;
7452 continue;
7453 }
7454
7455 else if (field_name_match (t_field_name, name))
7456 return ada_value_primitive_field (arg, offset, i, type);
7457
7458 else if (ada_is_wrapper_field (type, i))
7459 {
7460 struct value *v = /* Do not let indent join lines here. */
7461 ada_search_struct_field (name, arg,
7462 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7463 TYPE_FIELD_TYPE (type, i));
7464
7465 if (v != NULL)
7466 return v;
7467 }
7468
7469 else if (ada_is_variant_part (type, i))
7470 {
7471 /* PNH: Do we ever get here? See find_struct_field. */
7472 int j;
7473 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7474 i));
7475 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7476
7477 for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7478 {
7479 struct value *v = ada_search_struct_field /* Force line
7480 break. */
7481 (name, arg,
7482 var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7483 TYPE_FIELD_TYPE (field_type, j));
7484
7485 if (v != NULL)
7486 return v;
7487 }
7488 }
7489 }
7490
7491 /* Field not found so far. If this is a tagged type which
7492 has a parent, try finding that field in the parent now. */
7493
7494 if (parent_offset != -1)
7495 {
7496 struct value *v = ada_search_struct_field (
7497 name, arg, offset + TYPE_FIELD_BITPOS (type, parent_offset) / 8,
7498 TYPE_FIELD_TYPE (type, parent_offset));
7499
7500 if (v != NULL)
7501 return v;
7502 }
7503
7504 return NULL;
7505 }
7506
7507 static struct value *ada_index_struct_field_1 (int *, struct value *,
7508 int, struct type *);
7509
7510
7511 /* Return field #INDEX in ARG, where the index is that returned by
7512 * find_struct_field through its INDEX_P argument. Adjust the address
7513 * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7514 * If found, return value, else return NULL. */
7515
7516 static struct value *
7517 ada_index_struct_field (int index, struct value *arg, int offset,
7518 struct type *type)
7519 {
7520 return ada_index_struct_field_1 (&index, arg, offset, type);
7521 }
7522
7523
7524 /* Auxiliary function for ada_index_struct_field. Like
7525 * ada_index_struct_field, but takes index from *INDEX_P and modifies
7526 * *INDEX_P. */
7527
7528 static struct value *
7529 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7530 struct type *type)
7531 {
7532 int i;
7533 type = ada_check_typedef (type);
7534
7535 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7536 {
7537 if (TYPE_FIELD_NAME (type, i) == NULL)
7538 continue;
7539 else if (ada_is_wrapper_field (type, i))
7540 {
7541 struct value *v = /* Do not let indent join lines here. */
7542 ada_index_struct_field_1 (index_p, arg,
7543 offset + TYPE_FIELD_BITPOS (type, i) / 8,
7544 TYPE_FIELD_TYPE (type, i));
7545
7546 if (v != NULL)
7547 return v;
7548 }
7549
7550 else if (ada_is_variant_part (type, i))
7551 {
7552 /* PNH: Do we ever get here? See ada_search_struct_field,
7553 find_struct_field. */
7554 error (_("Cannot assign this kind of variant record"));
7555 }
7556 else if (*index_p == 0)
7557 return ada_value_primitive_field (arg, offset, i, type);
7558 else
7559 *index_p -= 1;
7560 }
7561 return NULL;
7562 }
7563
7564 /* Given ARG, a value of type (pointer or reference to a)*
7565 structure/union, extract the component named NAME from the ultimate
7566 target structure/union and return it as a value with its
7567 appropriate type.
7568
7569 The routine searches for NAME among all members of the structure itself
7570 and (recursively) among all members of any wrapper members
7571 (e.g., '_parent').
7572
7573 If NO_ERR, then simply return NULL in case of error, rather than
7574 calling error. */
7575
7576 struct value *
7577 ada_value_struct_elt (struct value *arg, const char *name, int no_err)
7578 {
7579 struct type *t, *t1;
7580 struct value *v;
7581
7582 v = NULL;
7583 t1 = t = ada_check_typedef (value_type (arg));
7584 if (TYPE_CODE (t) == TYPE_CODE_REF)
7585 {
7586 t1 = TYPE_TARGET_TYPE (t);
7587 if (t1 == NULL)
7588 goto BadValue;
7589 t1 = ada_check_typedef (t1);
7590 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7591 {
7592 arg = coerce_ref (arg);
7593 t = t1;
7594 }
7595 }
7596
7597 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7598 {
7599 t1 = TYPE_TARGET_TYPE (t);
7600 if (t1 == NULL)
7601 goto BadValue;
7602 t1 = ada_check_typedef (t1);
7603 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7604 {
7605 arg = value_ind (arg);
7606 t = t1;
7607 }
7608 else
7609 break;
7610 }
7611
7612 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
7613 goto BadValue;
7614
7615 if (t1 == t)
7616 v = ada_search_struct_field (name, arg, 0, t);
7617 else
7618 {
7619 int bit_offset, bit_size, byte_offset;
7620 struct type *field_type;
7621 CORE_ADDR address;
7622
7623 if (TYPE_CODE (t) == TYPE_CODE_PTR)
7624 address = value_address (ada_value_ind (arg));
7625 else
7626 address = value_address (ada_coerce_ref (arg));
7627
7628 /* Check to see if this is a tagged type. We also need to handle
7629 the case where the type is a reference to a tagged type, but
7630 we have to be careful to exclude pointers to tagged types.
7631 The latter should be shown as usual (as a pointer), whereas
7632 a reference should mostly be transparent to the user. */
7633
7634 if (ada_is_tagged_type (t1, 0)
7635 || (TYPE_CODE (t1) == TYPE_CODE_REF
7636 && ada_is_tagged_type (TYPE_TARGET_TYPE (t1), 0)))
7637 {
7638 /* We first try to find the searched field in the current type.
7639 If not found then let's look in the fixed type. */
7640
7641 if (!find_struct_field (name, t1, 0,
7642 &field_type, &byte_offset, &bit_offset,
7643 &bit_size, NULL))
7644 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7645 address, NULL, 1);
7646 }
7647 else
7648 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL,
7649 address, NULL, 1);
7650
7651 if (find_struct_field (name, t1, 0,
7652 &field_type, &byte_offset, &bit_offset,
7653 &bit_size, NULL))
7654 {
7655 if (bit_size != 0)
7656 {
7657 if (TYPE_CODE (t) == TYPE_CODE_REF)
7658 arg = ada_coerce_ref (arg);
7659 else
7660 arg = ada_value_ind (arg);
7661 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7662 bit_offset, bit_size,
7663 field_type);
7664 }
7665 else
7666 v = value_at_lazy (field_type, address + byte_offset);
7667 }
7668 }
7669
7670 if (v != NULL || no_err)
7671 return v;
7672 else
7673 error (_("There is no member named %s."), name);
7674
7675 BadValue:
7676 if (no_err)
7677 return NULL;
7678 else
7679 error (_("Attempt to extract a component of "
7680 "a value that is not a record."));
7681 }
7682
7683 /* Return a string representation of type TYPE. */
7684
7685 static std::string
7686 type_as_string (struct type *type)
7687 {
7688 string_file tmp_stream;
7689
7690 type_print (type, "", &tmp_stream, -1);
7691
7692 return std::move (tmp_stream.string ());
7693 }
7694
7695 /* Given a type TYPE, look up the type of the component of type named NAME.
7696 If DISPP is non-null, add its byte displacement from the beginning of a
7697 structure (pointed to by a value) of type TYPE to *DISPP (does not
7698 work for packed fields).
7699
7700 Matches any field whose name has NAME as a prefix, possibly
7701 followed by "___".
7702
7703 TYPE can be either a struct or union. If REFOK, TYPE may also
7704 be a (pointer or reference)+ to a struct or union, and the
7705 ultimate target type will be searched.
7706
7707 Looks recursively into variant clauses and parent types.
7708
7709 In the case of homonyms in the tagged types, please refer to the
7710 long explanation in find_struct_field's function documentation.
7711
7712 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7713 TYPE is not a type of the right kind. */
7714
7715 static struct type *
7716 ada_lookup_struct_elt_type (struct type *type, const char *name, int refok,
7717 int noerr)
7718 {
7719 int i;
7720 int parent_offset = -1;
7721
7722 if (name == NULL)
7723 goto BadName;
7724
7725 if (refok && type != NULL)
7726 while (1)
7727 {
7728 type = ada_check_typedef (type);
7729 if (TYPE_CODE (type) != TYPE_CODE_PTR
7730 && TYPE_CODE (type) != TYPE_CODE_REF)
7731 break;
7732 type = TYPE_TARGET_TYPE (type);
7733 }
7734
7735 if (type == NULL
7736 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7737 && TYPE_CODE (type) != TYPE_CODE_UNION))
7738 {
7739 if (noerr)
7740 return NULL;
7741
7742 error (_("Type %s is not a structure or union type"),
7743 type != NULL ? type_as_string (type).c_str () : _("(null)"));
7744 }
7745
7746 type = to_static_fixed_type (type);
7747
7748 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7749 {
7750 const char *t_field_name = TYPE_FIELD_NAME (type, i);
7751 struct type *t;
7752
7753 if (t_field_name == NULL)
7754 continue;
7755
7756 else if (ada_is_parent_field (type, i))
7757 {
7758 /* This is a field pointing us to the parent type of a tagged
7759 type. As hinted in this function's documentation, we give
7760 preference to fields in the current record first, so what
7761 we do here is just record the index of this field before
7762 we skip it. If it turns out we couldn't find our field
7763 in the current record, then we'll get back to it and search
7764 inside it whether the field might exist in the parent. */
7765
7766 parent_offset = i;
7767 continue;
7768 }
7769
7770 else if (field_name_match (t_field_name, name))
7771 return TYPE_FIELD_TYPE (type, i);
7772
7773 else if (ada_is_wrapper_field (type, i))
7774 {
7775 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7776 0, 1);
7777 if (t != NULL)
7778 return t;
7779 }
7780
7781 else if (ada_is_variant_part (type, i))
7782 {
7783 int j;
7784 struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7785 i));
7786
7787 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7788 {
7789 /* FIXME pnh 2008/01/26: We check for a field that is
7790 NOT wrapped in a struct, since the compiler sometimes
7791 generates these for unchecked variant types. Revisit
7792 if the compiler changes this practice. */
7793 const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7794
7795 if (v_field_name != NULL
7796 && field_name_match (v_field_name, name))
7797 t = TYPE_FIELD_TYPE (field_type, j);
7798 else
7799 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type,
7800 j),
7801 name, 0, 1);
7802
7803 if (t != NULL)
7804 return t;
7805 }
7806 }
7807
7808 }
7809
7810 /* Field not found so far. If this is a tagged type which
7811 has a parent, try finding that field in the parent now. */
7812
7813 if (parent_offset != -1)
7814 {
7815 struct type *t;
7816
7817 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, parent_offset),
7818 name, 0, 1);
7819 if (t != NULL)
7820 return t;
7821 }
7822
7823 BadName:
7824 if (!noerr)
7825 {
7826 const char *name_str = name != NULL ? name : _("<null>");
7827
7828 error (_("Type %s has no component named %s"),
7829 type_as_string (type).c_str (), name_str);
7830 }
7831
7832 return NULL;
7833 }
7834
7835 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7836 within a value of type OUTER_TYPE, return true iff VAR_TYPE
7837 represents an unchecked union (that is, the variant part of a
7838 record that is named in an Unchecked_Union pragma). */
7839
7840 static int
7841 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7842 {
7843 const char *discrim_name = ada_variant_discrim_name (var_type);
7844
7845 return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1) == NULL);
7846 }
7847
7848
7849 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7850 within a value of type OUTER_TYPE that is stored in GDB at
7851 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7852 numbering from 0) is applicable. Returns -1 if none are. */
7853
7854 int
7855 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7856 const gdb_byte *outer_valaddr)
7857 {
7858 int others_clause;
7859 int i;
7860 const char *discrim_name = ada_variant_discrim_name (var_type);
7861 struct value *outer;
7862 struct value *discrim;
7863 LONGEST discrim_val;
7864
7865 /* Using plain value_from_contents_and_address here causes problems
7866 because we will end up trying to resolve a type that is currently
7867 being constructed. */
7868 outer = value_from_contents_and_address_unresolved (outer_type,
7869 outer_valaddr, 0);
7870 discrim = ada_value_struct_elt (outer, discrim_name, 1);
7871 if (discrim == NULL)
7872 return -1;
7873 discrim_val = value_as_long (discrim);
7874
7875 others_clause = -1;
7876 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7877 {
7878 if (ada_is_others_clause (var_type, i))
7879 others_clause = i;
7880 else if (ada_in_variant (discrim_val, var_type, i))
7881 return i;
7882 }
7883
7884 return others_clause;
7885 }
7886
7887
7888
7889 /* Dynamic-Sized Records */
7890
7891 /* Strategy: The type ostensibly attached to a value with dynamic size
7892 (i.e., a size that is not statically recorded in the debugging
7893 data) does not accurately reflect the size or layout of the value.
7894 Our strategy is to convert these values to values with accurate,
7895 conventional types that are constructed on the fly. */
7896
7897 /* There is a subtle and tricky problem here. In general, we cannot
7898 determine the size of dynamic records without its data. However,
7899 the 'struct value' data structure, which GDB uses to represent
7900 quantities in the inferior process (the target), requires the size
7901 of the type at the time of its allocation in order to reserve space
7902 for GDB's internal copy of the data. That's why the
7903 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7904 rather than struct value*s.
7905
7906 However, GDB's internal history variables ($1, $2, etc.) are
7907 struct value*s containing internal copies of the data that are not, in
7908 general, the same as the data at their corresponding addresses in
7909 the target. Fortunately, the types we give to these values are all
7910 conventional, fixed-size types (as per the strategy described
7911 above), so that we don't usually have to perform the
7912 'to_fixed_xxx_type' conversions to look at their values.
7913 Unfortunately, there is one exception: if one of the internal
7914 history variables is an array whose elements are unconstrained
7915 records, then we will need to create distinct fixed types for each
7916 element selected. */
7917
7918 /* The upshot of all of this is that many routines take a (type, host
7919 address, target address) triple as arguments to represent a value.
7920 The host address, if non-null, is supposed to contain an internal
7921 copy of the relevant data; otherwise, the program is to consult the
7922 target at the target address. */
7923
7924 /* Assuming that VAL0 represents a pointer value, the result of
7925 dereferencing it. Differs from value_ind in its treatment of
7926 dynamic-sized types. */
7927
7928 struct value *
7929 ada_value_ind (struct value *val0)
7930 {
7931 struct value *val = value_ind (val0);
7932
7933 if (ada_is_tagged_type (value_type (val), 0))
7934 val = ada_tag_value_at_base_address (val);
7935
7936 return ada_to_fixed_value (val);
7937 }
7938
7939 /* The value resulting from dereferencing any "reference to"
7940 qualifiers on VAL0. */
7941
7942 static struct value *
7943 ada_coerce_ref (struct value *val0)
7944 {
7945 if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7946 {
7947 struct value *val = val0;
7948
7949 val = coerce_ref (val);
7950
7951 if (ada_is_tagged_type (value_type (val), 0))
7952 val = ada_tag_value_at_base_address (val);
7953
7954 return ada_to_fixed_value (val);
7955 }
7956 else
7957 return val0;
7958 }
7959
7960 /* Return OFF rounded upward if necessary to a multiple of
7961 ALIGNMENT (a power of 2). */
7962
7963 static unsigned int
7964 align_value (unsigned int off, unsigned int alignment)
7965 {
7966 return (off + alignment - 1) & ~(alignment - 1);
7967 }
7968
7969 /* Return the bit alignment required for field #F of template type TYPE. */
7970
7971 static unsigned int
7972 field_alignment (struct type *type, int f)
7973 {
7974 const char *name = TYPE_FIELD_NAME (type, f);
7975 int len;
7976 int align_offset;
7977
7978 /* The field name should never be null, unless the debugging information
7979 is somehow malformed. In this case, we assume the field does not
7980 require any alignment. */
7981 if (name == NULL)
7982 return 1;
7983
7984 len = strlen (name);
7985
7986 if (!isdigit (name[len - 1]))
7987 return 1;
7988
7989 if (isdigit (name[len - 2]))
7990 align_offset = len - 2;
7991 else
7992 align_offset = len - 1;
7993
7994 if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7995 return TARGET_CHAR_BIT;
7996
7997 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7998 }
7999
8000 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
8001
8002 static struct symbol *
8003 ada_find_any_type_symbol (const char *name)
8004 {
8005 struct symbol *sym;
8006
8007 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
8008 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
8009 return sym;
8010
8011 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
8012 return sym;
8013 }
8014
8015 /* Find a type named NAME. Ignores ambiguity. This routine will look
8016 solely for types defined by debug info, it will not search the GDB
8017 primitive types. */
8018
8019 static struct type *
8020 ada_find_any_type (const char *name)
8021 {
8022 struct symbol *sym = ada_find_any_type_symbol (name);
8023
8024 if (sym != NULL)
8025 return SYMBOL_TYPE (sym);
8026
8027 return NULL;
8028 }
8029
8030 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
8031 associated with NAME_SYM's name. NAME_SYM may itself be a renaming
8032 symbol, in which case it is returned. Otherwise, this looks for
8033 symbols whose name is that of NAME_SYM suffixed with "___XR".
8034 Return symbol if found, and NULL otherwise. */
8035
8036 struct symbol *
8037 ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
8038 {
8039 const char *name = SYMBOL_LINKAGE_NAME (name_sym);
8040 struct symbol *sym;
8041
8042 if (strstr (name, "___XR") != NULL)
8043 return name_sym;
8044
8045 sym = find_old_style_renaming_symbol (name, block);
8046
8047 if (sym != NULL)
8048 return sym;
8049
8050 /* Not right yet. FIXME pnh 7/20/2007. */
8051 sym = ada_find_any_type_symbol (name);
8052 if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
8053 return sym;
8054 else
8055 return NULL;
8056 }
8057
8058 static struct symbol *
8059 find_old_style_renaming_symbol (const char *name, const struct block *block)
8060 {
8061 const struct symbol *function_sym = block_linkage_function (block);
8062 char *rename;
8063
8064 if (function_sym != NULL)
8065 {
8066 /* If the symbol is defined inside a function, NAME is not fully
8067 qualified. This means we need to prepend the function name
8068 as well as adding the ``___XR'' suffix to build the name of
8069 the associated renaming symbol. */
8070 const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
8071 /* Function names sometimes contain suffixes used
8072 for instance to qualify nested subprograms. When building
8073 the XR type name, we need to make sure that this suffix is
8074 not included. So do not include any suffix in the function
8075 name length below. */
8076 int function_name_len = ada_name_prefix_len (function_name);
8077 const int rename_len = function_name_len + 2 /* "__" */
8078 + strlen (name) + 6 /* "___XR\0" */ ;
8079
8080 /* Strip the suffix if necessary. */
8081 ada_remove_trailing_digits (function_name, &function_name_len);
8082 ada_remove_po_subprogram_suffix (function_name, &function_name_len);
8083 ada_remove_Xbn_suffix (function_name, &function_name_len);
8084
8085 /* Library-level functions are a special case, as GNAT adds
8086 a ``_ada_'' prefix to the function name to avoid namespace
8087 pollution. However, the renaming symbols themselves do not
8088 have this prefix, so we need to skip this prefix if present. */
8089 if (function_name_len > 5 /* "_ada_" */
8090 && strstr (function_name, "_ada_") == function_name)
8091 {
8092 function_name += 5;
8093 function_name_len -= 5;
8094 }
8095
8096 rename = (char *) alloca (rename_len * sizeof (char));
8097 strncpy (rename, function_name, function_name_len);
8098 xsnprintf (rename + function_name_len, rename_len - function_name_len,
8099 "__%s___XR", name);
8100 }
8101 else
8102 {
8103 const int rename_len = strlen (name) + 6;
8104
8105 rename = (char *) alloca (rename_len * sizeof (char));
8106 xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
8107 }
8108
8109 return ada_find_any_type_symbol (rename);
8110 }
8111
8112 /* Because of GNAT encoding conventions, several GDB symbols may match a
8113 given type name. If the type denoted by TYPE0 is to be preferred to
8114 that of TYPE1 for purposes of type printing, return non-zero;
8115 otherwise return 0. */
8116
8117 int
8118 ada_prefer_type (struct type *type0, struct type *type1)
8119 {
8120 if (type1 == NULL)
8121 return 1;
8122 else if (type0 == NULL)
8123 return 0;
8124 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
8125 return 1;
8126 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
8127 return 0;
8128 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
8129 return 1;
8130 else if (ada_is_constrained_packed_array_type (type0))
8131 return 1;
8132 else if (ada_is_array_descriptor_type (type0)
8133 && !ada_is_array_descriptor_type (type1))
8134 return 1;
8135 else
8136 {
8137 const char *type0_name = type_name_no_tag (type0);
8138 const char *type1_name = type_name_no_tag (type1);
8139
8140 if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
8141 && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
8142 return 1;
8143 }
8144 return 0;
8145 }
8146
8147 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
8148 null, its TYPE_TAG_NAME. Null if TYPE is null. */
8149
8150 const char *
8151 ada_type_name (struct type *type)
8152 {
8153 if (type == NULL)
8154 return NULL;
8155 else if (TYPE_NAME (type) != NULL)
8156 return TYPE_NAME (type);
8157 else
8158 return TYPE_TAG_NAME (type);
8159 }
8160
8161 /* Search the list of "descriptive" types associated to TYPE for a type
8162 whose name is NAME. */
8163
8164 static struct type *
8165 find_parallel_type_by_descriptive_type (struct type *type, const char *name)
8166 {
8167 struct type *result, *tmp;
8168
8169 if (ada_ignore_descriptive_types_p)
8170 return NULL;
8171
8172 /* If there no descriptive-type info, then there is no parallel type
8173 to be found. */
8174 if (!HAVE_GNAT_AUX_INFO (type))
8175 return NULL;
8176
8177 result = TYPE_DESCRIPTIVE_TYPE (type);
8178 while (result != NULL)
8179 {
8180 const char *result_name = ada_type_name (result);
8181
8182 if (result_name == NULL)
8183 {
8184 warning (_("unexpected null name on descriptive type"));
8185 return NULL;
8186 }
8187
8188 /* If the names match, stop. */
8189 if (strcmp (result_name, name) == 0)
8190 break;
8191
8192 /* Otherwise, look at the next item on the list, if any. */
8193 if (HAVE_GNAT_AUX_INFO (result))
8194 tmp = TYPE_DESCRIPTIVE_TYPE (result);
8195 else
8196 tmp = NULL;
8197
8198 /* If not found either, try after having resolved the typedef. */
8199 if (tmp != NULL)
8200 result = tmp;
8201 else
8202 {
8203 result = check_typedef (result);
8204 if (HAVE_GNAT_AUX_INFO (result))
8205 result = TYPE_DESCRIPTIVE_TYPE (result);
8206 else
8207 result = NULL;
8208 }
8209 }
8210
8211 /* If we didn't find a match, see whether this is a packed array. With
8212 older compilers, the descriptive type information is either absent or
8213 irrelevant when it comes to packed arrays so the above lookup fails.
8214 Fall back to using a parallel lookup by name in this case. */
8215 if (result == NULL && ada_is_constrained_packed_array_type (type))
8216 return ada_find_any_type (name);
8217
8218 return result;
8219 }
8220
8221 /* Find a parallel type to TYPE with the specified NAME, using the
8222 descriptive type taken from the debugging information, if available,
8223 and otherwise using the (slower) name-based method. */
8224
8225 static struct type *
8226 ada_find_parallel_type_with_name (struct type *type, const char *name)
8227 {
8228 struct type *result = NULL;
8229
8230 if (HAVE_GNAT_AUX_INFO (type))
8231 result = find_parallel_type_by_descriptive_type (type, name);
8232 else
8233 result = ada_find_any_type (name);
8234
8235 return result;
8236 }
8237
8238 /* Same as above, but specify the name of the parallel type by appending
8239 SUFFIX to the name of TYPE. */
8240
8241 struct type *
8242 ada_find_parallel_type (struct type *type, const char *suffix)
8243 {
8244 char *name;
8245 const char *type_name = ada_type_name (type);
8246 int len;
8247
8248 if (type_name == NULL)
8249 return NULL;
8250
8251 len = strlen (type_name);
8252
8253 name = (char *) alloca (len + strlen (suffix) + 1);
8254
8255 strcpy (name, type_name);
8256 strcpy (name + len, suffix);
8257
8258 return ada_find_parallel_type_with_name (type, name);
8259 }
8260
8261 /* If TYPE is a variable-size record type, return the corresponding template
8262 type describing its fields. Otherwise, return NULL. */
8263
8264 static struct type *
8265 dynamic_template_type (struct type *type)
8266 {
8267 type = ada_check_typedef (type);
8268
8269 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
8270 || ada_type_name (type) == NULL)
8271 return NULL;
8272 else
8273 {
8274 int len = strlen (ada_type_name (type));
8275
8276 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
8277 return type;
8278 else
8279 return ada_find_parallel_type (type, "___XVE");
8280 }
8281 }
8282
8283 /* Assuming that TEMPL_TYPE is a union or struct type, returns
8284 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
8285
8286 static int
8287 is_dynamic_field (struct type *templ_type, int field_num)
8288 {
8289 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
8290
8291 return name != NULL
8292 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
8293 && strstr (name, "___XVL") != NULL;
8294 }
8295
8296 /* The index of the variant field of TYPE, or -1 if TYPE does not
8297 represent a variant record type. */
8298
8299 static int
8300 variant_field_index (struct type *type)
8301 {
8302 int f;
8303
8304 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
8305 return -1;
8306
8307 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
8308 {
8309 if (ada_is_variant_part (type, f))
8310 return f;
8311 }
8312 return -1;
8313 }
8314
8315 /* A record type with no fields. */
8316
8317 static struct type *
8318 empty_record (struct type *templ)
8319 {
8320 struct type *type = alloc_type_copy (templ);
8321
8322 TYPE_CODE (type) = TYPE_CODE_STRUCT;
8323 TYPE_NFIELDS (type) = 0;
8324 TYPE_FIELDS (type) = NULL;
8325 INIT_CPLUS_SPECIFIC (type);
8326 TYPE_NAME (type) = "<empty>";
8327 TYPE_TAG_NAME (type) = NULL;
8328 TYPE_LENGTH (type) = 0;
8329 return type;
8330 }
8331
8332 /* An ordinary record type (with fixed-length fields) that describes
8333 the value of type TYPE at VALADDR or ADDRESS (see comments at
8334 the beginning of this section) VAL according to GNAT conventions.
8335 DVAL0 should describe the (portion of a) record that contains any
8336 necessary discriminants. It should be NULL if value_type (VAL) is
8337 an outer-level type (i.e., as opposed to a branch of a variant.) A
8338 variant field (unless unchecked) is replaced by a particular branch
8339 of the variant.
8340
8341 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
8342 length are not statically known are discarded. As a consequence,
8343 VALADDR, ADDRESS and DVAL0 are ignored.
8344
8345 NOTE: Limitations: For now, we assume that dynamic fields and
8346 variants occupy whole numbers of bytes. However, they need not be
8347 byte-aligned. */
8348
8349 struct type *
8350 ada_template_to_fixed_record_type_1 (struct type *type,
8351 const gdb_byte *valaddr,
8352 CORE_ADDR address, struct value *dval0,
8353 int keep_dynamic_fields)
8354 {
8355 struct value *mark = value_mark ();
8356 struct value *dval;
8357 struct type *rtype;
8358 int nfields, bit_len;
8359 int variant_field;
8360 long off;
8361 int fld_bit_len;
8362 int f;
8363
8364 /* Compute the number of fields in this record type that are going
8365 to be processed: unless keep_dynamic_fields, this includes only
8366 fields whose position and length are static will be processed. */
8367 if (keep_dynamic_fields)
8368 nfields = TYPE_NFIELDS (type);
8369 else
8370 {
8371 nfields = 0;
8372 while (nfields < TYPE_NFIELDS (type)
8373 && !ada_is_variant_part (type, nfields)
8374 && !is_dynamic_field (type, nfields))
8375 nfields++;
8376 }
8377
8378 rtype = alloc_type_copy (type);
8379 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8380 INIT_CPLUS_SPECIFIC (rtype);
8381 TYPE_NFIELDS (rtype) = nfields;
8382 TYPE_FIELDS (rtype) = (struct field *)
8383 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8384 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8385 TYPE_NAME (rtype) = ada_type_name (type);
8386 TYPE_TAG_NAME (rtype) = NULL;
8387 TYPE_FIXED_INSTANCE (rtype) = 1;
8388
8389 off = 0;
8390 bit_len = 0;
8391 variant_field = -1;
8392
8393 for (f = 0; f < nfields; f += 1)
8394 {
8395 off = align_value (off, field_alignment (type, f))
8396 + TYPE_FIELD_BITPOS (type, f);
8397 SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
8398 TYPE_FIELD_BITSIZE (rtype, f) = 0;
8399
8400 if (ada_is_variant_part (type, f))
8401 {
8402 variant_field = f;
8403 fld_bit_len = 0;
8404 }
8405 else if (is_dynamic_field (type, f))
8406 {
8407 const gdb_byte *field_valaddr = valaddr;
8408 CORE_ADDR field_address = address;
8409 struct type *field_type =
8410 TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8411
8412 if (dval0 == NULL)
8413 {
8414 /* rtype's length is computed based on the run-time
8415 value of discriminants. If the discriminants are not
8416 initialized, the type size may be completely bogus and
8417 GDB may fail to allocate a value for it. So check the
8418 size first before creating the value. */
8419 ada_ensure_varsize_limit (rtype);
8420 /* Using plain value_from_contents_and_address here
8421 causes problems because we will end up trying to
8422 resolve a type that is currently being
8423 constructed. */
8424 dval = value_from_contents_and_address_unresolved (rtype,
8425 valaddr,
8426 address);
8427 rtype = value_type (dval);
8428 }
8429 else
8430 dval = dval0;
8431
8432 /* If the type referenced by this field is an aligner type, we need
8433 to unwrap that aligner type, because its size might not be set.
8434 Keeping the aligner type would cause us to compute the wrong
8435 size for this field, impacting the offset of the all the fields
8436 that follow this one. */
8437 if (ada_is_aligner_type (field_type))
8438 {
8439 long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8440
8441 field_valaddr = cond_offset_host (field_valaddr, field_offset);
8442 field_address = cond_offset_target (field_address, field_offset);
8443 field_type = ada_aligned_type (field_type);
8444 }
8445
8446 field_valaddr = cond_offset_host (field_valaddr,
8447 off / TARGET_CHAR_BIT);
8448 field_address = cond_offset_target (field_address,
8449 off / TARGET_CHAR_BIT);
8450
8451 /* Get the fixed type of the field. Note that, in this case,
8452 we do not want to get the real type out of the tag: if
8453 the current field is the parent part of a tagged record,
8454 we will get the tag of the object. Clearly wrong: the real
8455 type of the parent is not the real type of the child. We
8456 would end up in an infinite loop. */
8457 field_type = ada_get_base_type (field_type);
8458 field_type = ada_to_fixed_type (field_type, field_valaddr,
8459 field_address, dval, 0);
8460 /* If the field size is already larger than the maximum
8461 object size, then the record itself will necessarily
8462 be larger than the maximum object size. We need to make
8463 this check now, because the size might be so ridiculously
8464 large (due to an uninitialized variable in the inferior)
8465 that it would cause an overflow when adding it to the
8466 record size. */
8467 ada_ensure_varsize_limit (field_type);
8468
8469 TYPE_FIELD_TYPE (rtype, f) = field_type;
8470 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8471 /* The multiplication can potentially overflow. But because
8472 the field length has been size-checked just above, and
8473 assuming that the maximum size is a reasonable value,
8474 an overflow should not happen in practice. So rather than
8475 adding overflow recovery code to this already complex code,
8476 we just assume that it's not going to happen. */
8477 fld_bit_len =
8478 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
8479 }
8480 else
8481 {
8482 /* Note: If this field's type is a typedef, it is important
8483 to preserve the typedef layer.
8484
8485 Otherwise, we might be transforming a typedef to a fat
8486 pointer (encoding a pointer to an unconstrained array),
8487 into a basic fat pointer (encoding an unconstrained
8488 array). As both types are implemented using the same
8489 structure, the typedef is the only clue which allows us
8490 to distinguish between the two options. Stripping it
8491 would prevent us from printing this field appropriately. */
8492 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
8493 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8494 if (TYPE_FIELD_BITSIZE (type, f) > 0)
8495 fld_bit_len =
8496 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8497 else
8498 {
8499 struct type *field_type = TYPE_FIELD_TYPE (type, f);
8500
8501 /* We need to be careful of typedefs when computing
8502 the length of our field. If this is a typedef,
8503 get the length of the target type, not the length
8504 of the typedef. */
8505 if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8506 field_type = ada_typedef_target_type (field_type);
8507
8508 fld_bit_len =
8509 TYPE_LENGTH (ada_check_typedef (field_type)) * TARGET_CHAR_BIT;
8510 }
8511 }
8512 if (off + fld_bit_len > bit_len)
8513 bit_len = off + fld_bit_len;
8514 off += fld_bit_len;
8515 TYPE_LENGTH (rtype) =
8516 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8517 }
8518
8519 /* We handle the variant part, if any, at the end because of certain
8520 odd cases in which it is re-ordered so as NOT to be the last field of
8521 the record. This can happen in the presence of representation
8522 clauses. */
8523 if (variant_field >= 0)
8524 {
8525 struct type *branch_type;
8526
8527 off = TYPE_FIELD_BITPOS (rtype, variant_field);
8528
8529 if (dval0 == NULL)
8530 {
8531 /* Using plain value_from_contents_and_address here causes
8532 problems because we will end up trying to resolve a type
8533 that is currently being constructed. */
8534 dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8535 address);
8536 rtype = value_type (dval);
8537 }
8538 else
8539 dval = dval0;
8540
8541 branch_type =
8542 to_fixed_variant_branch_type
8543 (TYPE_FIELD_TYPE (type, variant_field),
8544 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8545 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8546 if (branch_type == NULL)
8547 {
8548 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8549 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8550 TYPE_NFIELDS (rtype) -= 1;
8551 }
8552 else
8553 {
8554 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8555 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8556 fld_bit_len =
8557 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8558 TARGET_CHAR_BIT;
8559 if (off + fld_bit_len > bit_len)
8560 bit_len = off + fld_bit_len;
8561 TYPE_LENGTH (rtype) =
8562 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
8563 }
8564 }
8565
8566 /* According to exp_dbug.ads, the size of TYPE for variable-size records
8567 should contain the alignment of that record, which should be a strictly
8568 positive value. If null or negative, then something is wrong, most
8569 probably in the debug info. In that case, we don't round up the size
8570 of the resulting type. If this record is not part of another structure,
8571 the current RTYPE length might be good enough for our purposes. */
8572 if (TYPE_LENGTH (type) <= 0)
8573 {
8574 if (TYPE_NAME (rtype))
8575 warning (_("Invalid type size for `%s' detected: %d."),
8576 TYPE_NAME (rtype), TYPE_LENGTH (type));
8577 else
8578 warning (_("Invalid type size for <unnamed> detected: %d."),
8579 TYPE_LENGTH (type));
8580 }
8581 else
8582 {
8583 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8584 TYPE_LENGTH (type));
8585 }
8586
8587 value_free_to_mark (mark);
8588 if (TYPE_LENGTH (rtype) > varsize_limit)
8589 error (_("record type with dynamic size is larger than varsize-limit"));
8590 return rtype;
8591 }
8592
8593 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8594 of 1. */
8595
8596 static struct type *
8597 template_to_fixed_record_type (struct type *type, const gdb_byte *valaddr,
8598 CORE_ADDR address, struct value *dval0)
8599 {
8600 return ada_template_to_fixed_record_type_1 (type, valaddr,
8601 address, dval0, 1);
8602 }
8603
8604 /* An ordinary record type in which ___XVL-convention fields and
8605 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8606 static approximations, containing all possible fields. Uses
8607 no runtime values. Useless for use in values, but that's OK,
8608 since the results are used only for type determinations. Works on both
8609 structs and unions. Representation note: to save space, we memorize
8610 the result of this function in the TYPE_TARGET_TYPE of the
8611 template type. */
8612
8613 static struct type *
8614 template_to_static_fixed_type (struct type *type0)
8615 {
8616 struct type *type;
8617 int nfields;
8618 int f;
8619
8620 /* No need no do anything if the input type is already fixed. */
8621 if (TYPE_FIXED_INSTANCE (type0))
8622 return type0;
8623
8624 /* Likewise if we already have computed the static approximation. */
8625 if (TYPE_TARGET_TYPE (type0) != NULL)
8626 return TYPE_TARGET_TYPE (type0);
8627
8628 /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8629 type = type0;
8630 nfields = TYPE_NFIELDS (type0);
8631
8632 /* Whether or not we cloned TYPE0, cache the result so that we don't do
8633 recompute all over next time. */
8634 TYPE_TARGET_TYPE (type0) = type;
8635
8636 for (f = 0; f < nfields; f += 1)
8637 {
8638 struct type *field_type = TYPE_FIELD_TYPE (type0, f);
8639 struct type *new_type;
8640
8641 if (is_dynamic_field (type0, f))
8642 {
8643 field_type = ada_check_typedef (field_type);
8644 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8645 }
8646 else
8647 new_type = static_unwrap_type (field_type);
8648
8649 if (new_type != field_type)
8650 {
8651 /* Clone TYPE0 only the first time we get a new field type. */
8652 if (type == type0)
8653 {
8654 TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8655 TYPE_CODE (type) = TYPE_CODE (type0);
8656 INIT_CPLUS_SPECIFIC (type);
8657 TYPE_NFIELDS (type) = nfields;
8658 TYPE_FIELDS (type) = (struct field *)
8659 TYPE_ALLOC (type, nfields * sizeof (struct field));
8660 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8661 sizeof (struct field) * nfields);
8662 TYPE_NAME (type) = ada_type_name (type0);
8663 TYPE_TAG_NAME (type) = NULL;
8664 TYPE_FIXED_INSTANCE (type) = 1;
8665 TYPE_LENGTH (type) = 0;
8666 }
8667 TYPE_FIELD_TYPE (type, f) = new_type;
8668 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8669 }
8670 }
8671
8672 return type;
8673 }
8674
8675 /* Given an object of type TYPE whose contents are at VALADDR and
8676 whose address in memory is ADDRESS, returns a revision of TYPE,
8677 which should be a non-dynamic-sized record, in which the variant
8678 part, if any, is replaced with the appropriate branch. Looks
8679 for discriminant values in DVAL0, which can be NULL if the record
8680 contains the necessary discriminant values. */
8681
8682 static struct type *
8683 to_record_with_fixed_variant_part (struct type *type, const gdb_byte *valaddr,
8684 CORE_ADDR address, struct value *dval0)
8685 {
8686 struct value *mark = value_mark ();
8687 struct value *dval;
8688 struct type *rtype;
8689 struct type *branch_type;
8690 int nfields = TYPE_NFIELDS (type);
8691 int variant_field = variant_field_index (type);
8692
8693 if (variant_field == -1)
8694 return type;
8695
8696 if (dval0 == NULL)
8697 {
8698 dval = value_from_contents_and_address (type, valaddr, address);
8699 type = value_type (dval);
8700 }
8701 else
8702 dval = dval0;
8703
8704 rtype = alloc_type_copy (type);
8705 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8706 INIT_CPLUS_SPECIFIC (rtype);
8707 TYPE_NFIELDS (rtype) = nfields;
8708 TYPE_FIELDS (rtype) =
8709 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8710 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
8711 sizeof (struct field) * nfields);
8712 TYPE_NAME (rtype) = ada_type_name (type);
8713 TYPE_TAG_NAME (rtype) = NULL;
8714 TYPE_FIXED_INSTANCE (rtype) = 1;
8715 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8716
8717 branch_type = to_fixed_variant_branch_type
8718 (TYPE_FIELD_TYPE (type, variant_field),
8719 cond_offset_host (valaddr,
8720 TYPE_FIELD_BITPOS (type, variant_field)
8721 / TARGET_CHAR_BIT),
8722 cond_offset_target (address,
8723 TYPE_FIELD_BITPOS (type, variant_field)
8724 / TARGET_CHAR_BIT), dval);
8725 if (branch_type == NULL)
8726 {
8727 int f;
8728
8729 for (f = variant_field + 1; f < nfields; f += 1)
8730 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8731 TYPE_NFIELDS (rtype) -= 1;
8732 }
8733 else
8734 {
8735 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8736 TYPE_FIELD_NAME (rtype, variant_field) = "S";
8737 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8738 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8739 }
8740 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
8741
8742 value_free_to_mark (mark);
8743 return rtype;
8744 }
8745
8746 /* An ordinary record type (with fixed-length fields) that describes
8747 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8748 beginning of this section]. Any necessary discriminants' values
8749 should be in DVAL, a record value; it may be NULL if the object
8750 at ADDR itself contains any necessary discriminant values.
8751 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8752 values from the record are needed. Except in the case that DVAL,
8753 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8754 unchecked) is replaced by a particular branch of the variant.
8755
8756 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8757 is questionable and may be removed. It can arise during the
8758 processing of an unconstrained-array-of-record type where all the
8759 variant branches have exactly the same size. This is because in
8760 such cases, the compiler does not bother to use the XVS convention
8761 when encoding the record. I am currently dubious of this
8762 shortcut and suspect the compiler should be altered. FIXME. */
8763
8764 static struct type *
8765 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8766 CORE_ADDR address, struct value *dval)
8767 {
8768 struct type *templ_type;
8769
8770 if (TYPE_FIXED_INSTANCE (type0))
8771 return type0;
8772
8773 templ_type = dynamic_template_type (type0);
8774
8775 if (templ_type != NULL)
8776 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8777 else if (variant_field_index (type0) >= 0)
8778 {
8779 if (dval == NULL && valaddr == NULL && address == 0)
8780 return type0;
8781 return to_record_with_fixed_variant_part (type0, valaddr, address,
8782 dval);
8783 }
8784 else
8785 {
8786 TYPE_FIXED_INSTANCE (type0) = 1;
8787 return type0;
8788 }
8789
8790 }
8791
8792 /* An ordinary record type (with fixed-length fields) that describes
8793 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8794 union type. Any necessary discriminants' values should be in DVAL,
8795 a record value. That is, this routine selects the appropriate
8796 branch of the union at ADDR according to the discriminant value
8797 indicated in the union's type name. Returns VAR_TYPE0 itself if
8798 it represents a variant subject to a pragma Unchecked_Union. */
8799
8800 static struct type *
8801 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8802 CORE_ADDR address, struct value *dval)
8803 {
8804 int which;
8805 struct type *templ_type;
8806 struct type *var_type;
8807
8808 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8809 var_type = TYPE_TARGET_TYPE (var_type0);
8810 else
8811 var_type = var_type0;
8812
8813 templ_type = ada_find_parallel_type (var_type, "___XVU");
8814
8815 if (templ_type != NULL)
8816 var_type = templ_type;
8817
8818 if (is_unchecked_variant (var_type, value_type (dval)))
8819 return var_type0;
8820 which =
8821 ada_which_variant_applies (var_type,
8822 value_type (dval), value_contents (dval));
8823
8824 if (which < 0)
8825 return empty_record (var_type);
8826 else if (is_dynamic_field (var_type, which))
8827 return to_fixed_record_type
8828 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8829 valaddr, address, dval);
8830 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8831 return
8832 to_fixed_record_type
8833 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8834 else
8835 return TYPE_FIELD_TYPE (var_type, which);
8836 }
8837
8838 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8839 ENCODING_TYPE, a type following the GNAT conventions for discrete
8840 type encodings, only carries redundant information. */
8841
8842 static int
8843 ada_is_redundant_range_encoding (struct type *range_type,
8844 struct type *encoding_type)
8845 {
8846 const char *bounds_str;
8847 int n;
8848 LONGEST lo, hi;
8849
8850 gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8851
8852 if (TYPE_CODE (get_base_type (range_type))
8853 != TYPE_CODE (get_base_type (encoding_type)))
8854 {
8855 /* The compiler probably used a simple base type to describe
8856 the range type instead of the range's actual base type,
8857 expecting us to get the real base type from the encoding
8858 anyway. In this situation, the encoding cannot be ignored
8859 as redundant. */
8860 return 0;
8861 }
8862
8863 if (is_dynamic_type (range_type))
8864 return 0;
8865
8866 if (TYPE_NAME (encoding_type) == NULL)
8867 return 0;
8868
8869 bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8870 if (bounds_str == NULL)
8871 return 0;
8872
8873 n = 8; /* Skip "___XDLU_". */
8874 if (!ada_scan_number (bounds_str, n, &lo, &n))
8875 return 0;
8876 if (TYPE_LOW_BOUND (range_type) != lo)
8877 return 0;
8878
8879 n += 2; /* Skip the "__" separator between the two bounds. */
8880 if (!ada_scan_number (bounds_str, n, &hi, &n))
8881 return 0;
8882 if (TYPE_HIGH_BOUND (range_type) != hi)
8883 return 0;
8884
8885 return 1;
8886 }
8887
8888 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8889 a type following the GNAT encoding for describing array type
8890 indices, only carries redundant information. */
8891
8892 static int
8893 ada_is_redundant_index_type_desc (struct type *array_type,
8894 struct type *desc_type)
8895 {
8896 struct type *this_layer = check_typedef (array_type);
8897 int i;
8898
8899 for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8900 {
8901 if (!ada_is_redundant_range_encoding (TYPE_INDEX_TYPE (this_layer),
8902 TYPE_FIELD_TYPE (desc_type, i)))
8903 return 0;
8904 this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8905 }
8906
8907 return 1;
8908 }
8909
8910 /* Assuming that TYPE0 is an array type describing the type of a value
8911 at ADDR, and that DVAL describes a record containing any
8912 discriminants used in TYPE0, returns a type for the value that
8913 contains no dynamic components (that is, no components whose sizes
8914 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8915 true, gives an error message if the resulting type's size is over
8916 varsize_limit. */
8917
8918 static struct type *
8919 to_fixed_array_type (struct type *type0, struct value *dval,
8920 int ignore_too_big)
8921 {
8922 struct type *index_type_desc;
8923 struct type *result;
8924 int constrained_packed_array_p;
8925 static const char *xa_suffix = "___XA";
8926
8927 type0 = ada_check_typedef (type0);
8928 if (TYPE_FIXED_INSTANCE (type0))
8929 return type0;
8930
8931 constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8932 if (constrained_packed_array_p)
8933 type0 = decode_constrained_packed_array_type (type0);
8934
8935 index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8936
8937 /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8938 encoding suffixed with 'P' may still be generated. If so,
8939 it should be used to find the XA type. */
8940
8941 if (index_type_desc == NULL)
8942 {
8943 const char *type_name = ada_type_name (type0);
8944
8945 if (type_name != NULL)
8946 {
8947 const int len = strlen (type_name);
8948 char *name = (char *) alloca (len + strlen (xa_suffix));
8949
8950 if (type_name[len - 1] == 'P')
8951 {
8952 strcpy (name, type_name);
8953 strcpy (name + len - 1, xa_suffix);
8954 index_type_desc = ada_find_parallel_type_with_name (type0, name);
8955 }
8956 }
8957 }
8958
8959 ada_fixup_array_indexes_type (index_type_desc);
8960 if (index_type_desc != NULL
8961 && ada_is_redundant_index_type_desc (type0, index_type_desc))
8962 {
8963 /* Ignore this ___XA parallel type, as it does not bring any
8964 useful information. This allows us to avoid creating fixed
8965 versions of the array's index types, which would be identical
8966 to the original ones. This, in turn, can also help avoid
8967 the creation of fixed versions of the array itself. */
8968 index_type_desc = NULL;
8969 }
8970
8971 if (index_type_desc == NULL)
8972 {
8973 struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8974
8975 /* NOTE: elt_type---the fixed version of elt_type0---should never
8976 depend on the contents of the array in properly constructed
8977 debugging data. */
8978 /* Create a fixed version of the array element type.
8979 We're not providing the address of an element here,
8980 and thus the actual object value cannot be inspected to do
8981 the conversion. This should not be a problem, since arrays of
8982 unconstrained objects are not allowed. In particular, all
8983 the elements of an array of a tagged type should all be of
8984 the same type specified in the debugging info. No need to
8985 consult the object tag. */
8986 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8987
8988 /* Make sure we always create a new array type when dealing with
8989 packed array types, since we're going to fix-up the array
8990 type length and element bitsize a little further down. */
8991 if (elt_type0 == elt_type && !constrained_packed_array_p)
8992 result = type0;
8993 else
8994 result = create_array_type (alloc_type_copy (type0),
8995 elt_type, TYPE_INDEX_TYPE (type0));
8996 }
8997 else
8998 {
8999 int i;
9000 struct type *elt_type0;
9001
9002 elt_type0 = type0;
9003 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
9004 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
9005
9006 /* NOTE: result---the fixed version of elt_type0---should never
9007 depend on the contents of the array in properly constructed
9008 debugging data. */
9009 /* Create a fixed version of the array element type.
9010 We're not providing the address of an element here,
9011 and thus the actual object value cannot be inspected to do
9012 the conversion. This should not be a problem, since arrays of
9013 unconstrained objects are not allowed. In particular, all
9014 the elements of an array of a tagged type should all be of
9015 the same type specified in the debugging info. No need to
9016 consult the object tag. */
9017 result =
9018 ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
9019
9020 elt_type0 = type0;
9021 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
9022 {
9023 struct type *range_type =
9024 to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
9025
9026 result = create_array_type (alloc_type_copy (elt_type0),
9027 result, range_type);
9028 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
9029 }
9030 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
9031 error (_("array type with dynamic size is larger than varsize-limit"));
9032 }
9033
9034 /* We want to preserve the type name. This can be useful when
9035 trying to get the type name of a value that has already been
9036 printed (for instance, if the user did "print VAR; whatis $". */
9037 TYPE_NAME (result) = TYPE_NAME (type0);
9038
9039 if (constrained_packed_array_p)
9040 {
9041 /* So far, the resulting type has been created as if the original
9042 type was a regular (non-packed) array type. As a result, the
9043 bitsize of the array elements needs to be set again, and the array
9044 length needs to be recomputed based on that bitsize. */
9045 int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
9046 int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
9047
9048 TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
9049 TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
9050 if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
9051 TYPE_LENGTH (result)++;
9052 }
9053
9054 TYPE_FIXED_INSTANCE (result) = 1;
9055 return result;
9056 }
9057
9058
9059 /* A standard type (containing no dynamically sized components)
9060 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
9061 DVAL describes a record containing any discriminants used in TYPE0,
9062 and may be NULL if there are none, or if the object of type TYPE at
9063 ADDRESS or in VALADDR contains these discriminants.
9064
9065 If CHECK_TAG is not null, in the case of tagged types, this function
9066 attempts to locate the object's tag and use it to compute the actual
9067 type. However, when ADDRESS is null, we cannot use it to determine the
9068 location of the tag, and therefore compute the tagged type's actual type.
9069 So we return the tagged type without consulting the tag. */
9070
9071 static struct type *
9072 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
9073 CORE_ADDR address, struct value *dval, int check_tag)
9074 {
9075 type = ada_check_typedef (type);
9076 switch (TYPE_CODE (type))
9077 {
9078 default:
9079 return type;
9080 case TYPE_CODE_STRUCT:
9081 {
9082 struct type *static_type = to_static_fixed_type (type);
9083 struct type *fixed_record_type =
9084 to_fixed_record_type (type, valaddr, address, NULL);
9085
9086 /* If STATIC_TYPE is a tagged type and we know the object's address,
9087 then we can determine its tag, and compute the object's actual
9088 type from there. Note that we have to use the fixed record
9089 type (the parent part of the record may have dynamic fields
9090 and the way the location of _tag is expressed may depend on
9091 them). */
9092
9093 if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
9094 {
9095 struct value *tag =
9096 value_tag_from_contents_and_address
9097 (fixed_record_type,
9098 valaddr,
9099 address);
9100 struct type *real_type = type_from_tag (tag);
9101 struct value *obj =
9102 value_from_contents_and_address (fixed_record_type,
9103 valaddr,
9104 address);
9105 fixed_record_type = value_type (obj);
9106 if (real_type != NULL)
9107 return to_fixed_record_type
9108 (real_type, NULL,
9109 value_address (ada_tag_value_at_base_address (obj)), NULL);
9110 }
9111
9112 /* Check to see if there is a parallel ___XVZ variable.
9113 If there is, then it provides the actual size of our type. */
9114 else if (ada_type_name (fixed_record_type) != NULL)
9115 {
9116 const char *name = ada_type_name (fixed_record_type);
9117 char *xvz_name
9118 = (char *) alloca (strlen (name) + 7 /* "___XVZ\0" */);
9119 bool xvz_found = false;
9120 LONGEST size;
9121
9122 xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
9123 TRY
9124 {
9125 xvz_found = get_int_var_value (xvz_name, size);
9126 }
9127 CATCH (except, RETURN_MASK_ERROR)
9128 {
9129 /* We found the variable, but somehow failed to read
9130 its value. Rethrow the same error, but with a little
9131 bit more information, to help the user understand
9132 what went wrong (Eg: the variable might have been
9133 optimized out). */
9134 throw_error (except.error,
9135 _("unable to read value of %s (%s)"),
9136 xvz_name, except.message);
9137 }
9138 END_CATCH
9139
9140 if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
9141 {
9142 fixed_record_type = copy_type (fixed_record_type);
9143 TYPE_LENGTH (fixed_record_type) = size;
9144
9145 /* The FIXED_RECORD_TYPE may have be a stub. We have
9146 observed this when the debugging info is STABS, and
9147 apparently it is something that is hard to fix.
9148
9149 In practice, we don't need the actual type definition
9150 at all, because the presence of the XVZ variable allows us
9151 to assume that there must be a XVS type as well, which we
9152 should be able to use later, when we need the actual type
9153 definition.
9154
9155 In the meantime, pretend that the "fixed" type we are
9156 returning is NOT a stub, because this can cause trouble
9157 when using this type to create new types targeting it.
9158 Indeed, the associated creation routines often check
9159 whether the target type is a stub and will try to replace
9160 it, thus using a type with the wrong size. This, in turn,
9161 might cause the new type to have the wrong size too.
9162 Consider the case of an array, for instance, where the size
9163 of the array is computed from the number of elements in
9164 our array multiplied by the size of its element. */
9165 TYPE_STUB (fixed_record_type) = 0;
9166 }
9167 }
9168 return fixed_record_type;
9169 }
9170 case TYPE_CODE_ARRAY:
9171 return to_fixed_array_type (type, dval, 1);
9172 case TYPE_CODE_UNION:
9173 if (dval == NULL)
9174 return type;
9175 else
9176 return to_fixed_variant_branch_type (type, valaddr, address, dval);
9177 }
9178 }
9179
9180 /* The same as ada_to_fixed_type_1, except that it preserves the type
9181 if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
9182
9183 The typedef layer needs be preserved in order to differentiate between
9184 arrays and array pointers when both types are implemented using the same
9185 fat pointer. In the array pointer case, the pointer is encoded as
9186 a typedef of the pointer type. For instance, considering:
9187
9188 type String_Access is access String;
9189 S1 : String_Access := null;
9190
9191 To the debugger, S1 is defined as a typedef of type String. But
9192 to the user, it is a pointer. So if the user tries to print S1,
9193 we should not dereference the array, but print the array address
9194 instead.
9195
9196 If we didn't preserve the typedef layer, we would lose the fact that
9197 the type is to be presented as a pointer (needs de-reference before
9198 being printed). And we would also use the source-level type name. */
9199
9200 struct type *
9201 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
9202 CORE_ADDR address, struct value *dval, int check_tag)
9203
9204 {
9205 struct type *fixed_type =
9206 ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
9207
9208 /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
9209 then preserve the typedef layer.
9210
9211 Implementation note: We can only check the main-type portion of
9212 the TYPE and FIXED_TYPE, because eliminating the typedef layer
9213 from TYPE now returns a type that has the same instance flags
9214 as TYPE. For instance, if TYPE is a "typedef const", and its
9215 target type is a "struct", then the typedef elimination will return
9216 a "const" version of the target type. See check_typedef for more
9217 details about how the typedef layer elimination is done.
9218
9219 brobecker/2010-11-19: It seems to me that the only case where it is
9220 useful to preserve the typedef layer is when dealing with fat pointers.
9221 Perhaps, we could add a check for that and preserve the typedef layer
9222 only in that situation. But this seems unecessary so far, probably
9223 because we call check_typedef/ada_check_typedef pretty much everywhere.
9224 */
9225 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9226 && (TYPE_MAIN_TYPE (ada_typedef_target_type (type))
9227 == TYPE_MAIN_TYPE (fixed_type)))
9228 return type;
9229
9230 return fixed_type;
9231 }
9232
9233 /* A standard (static-sized) type corresponding as well as possible to
9234 TYPE0, but based on no runtime data. */
9235
9236 static struct type *
9237 to_static_fixed_type (struct type *type0)
9238 {
9239 struct type *type;
9240
9241 if (type0 == NULL)
9242 return NULL;
9243
9244 if (TYPE_FIXED_INSTANCE (type0))
9245 return type0;
9246
9247 type0 = ada_check_typedef (type0);
9248
9249 switch (TYPE_CODE (type0))
9250 {
9251 default:
9252 return type0;
9253 case TYPE_CODE_STRUCT:
9254 type = dynamic_template_type (type0);
9255 if (type != NULL)
9256 return template_to_static_fixed_type (type);
9257 else
9258 return template_to_static_fixed_type (type0);
9259 case TYPE_CODE_UNION:
9260 type = ada_find_parallel_type (type0, "___XVU");
9261 if (type != NULL)
9262 return template_to_static_fixed_type (type);
9263 else
9264 return template_to_static_fixed_type (type0);
9265 }
9266 }
9267
9268 /* A static approximation of TYPE with all type wrappers removed. */
9269
9270 static struct type *
9271 static_unwrap_type (struct type *type)
9272 {
9273 if (ada_is_aligner_type (type))
9274 {
9275 struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
9276 if (ada_type_name (type1) == NULL)
9277 TYPE_NAME (type1) = ada_type_name (type);
9278
9279 return static_unwrap_type (type1);
9280 }
9281 else
9282 {
9283 struct type *raw_real_type = ada_get_base_type (type);
9284
9285 if (raw_real_type == type)
9286 return type;
9287 else
9288 return to_static_fixed_type (raw_real_type);
9289 }
9290 }
9291
9292 /* In some cases, incomplete and private types require
9293 cross-references that are not resolved as records (for example,
9294 type Foo;
9295 type FooP is access Foo;
9296 V: FooP;
9297 type Foo is array ...;
9298 ). In these cases, since there is no mechanism for producing
9299 cross-references to such types, we instead substitute for FooP a
9300 stub enumeration type that is nowhere resolved, and whose tag is
9301 the name of the actual type. Call these types "non-record stubs". */
9302
9303 /* A type equivalent to TYPE that is not a non-record stub, if one
9304 exists, otherwise TYPE. */
9305
9306 struct type *
9307 ada_check_typedef (struct type *type)
9308 {
9309 if (type == NULL)
9310 return NULL;
9311
9312 /* If our type is a typedef type of a fat pointer, then we're done.
9313 We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
9314 what allows us to distinguish between fat pointers that represent
9315 array types, and fat pointers that represent array access types
9316 (in both cases, the compiler implements them as fat pointers). */
9317 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
9318 && is_thick_pntr (ada_typedef_target_type (type)))
9319 return type;
9320
9321 type = check_typedef (type);
9322 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
9323 || !TYPE_STUB (type)
9324 || TYPE_TAG_NAME (type) == NULL)
9325 return type;
9326 else
9327 {
9328 const char *name = TYPE_TAG_NAME (type);
9329 struct type *type1 = ada_find_any_type (name);
9330
9331 if (type1 == NULL)
9332 return type;
9333
9334 /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
9335 stubs pointing to arrays, as we don't create symbols for array
9336 types, only for the typedef-to-array types). If that's the case,
9337 strip the typedef layer. */
9338 if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
9339 type1 = ada_check_typedef (type1);
9340
9341 return type1;
9342 }
9343 }
9344
9345 /* A value representing the data at VALADDR/ADDRESS as described by
9346 type TYPE0, but with a standard (static-sized) type that correctly
9347 describes it. If VAL0 is not NULL and TYPE0 already is a standard
9348 type, then return VAL0 [this feature is simply to avoid redundant
9349 creation of struct values]. */
9350
9351 static struct value *
9352 ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
9353 struct value *val0)
9354 {
9355 struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
9356
9357 if (type == type0 && val0 != NULL)
9358 return val0;
9359 else
9360 return value_from_contents_and_address (type, 0, address);
9361 }
9362
9363 /* A value representing VAL, but with a standard (static-sized) type
9364 that correctly describes it. Does not necessarily create a new
9365 value. */
9366
9367 struct value *
9368 ada_to_fixed_value (struct value *val)
9369 {
9370 val = unwrap_value (val);
9371 val = ada_to_fixed_value_create (value_type (val),
9372 value_address (val),
9373 val);
9374 return val;
9375 }
9376
9377
9378 /* Attributes */
9379
9380 /* Table mapping attribute numbers to names.
9381 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9382
9383 static const char *attribute_names[] = {
9384 "<?>",
9385
9386 "first",
9387 "last",
9388 "length",
9389 "image",
9390 "max",
9391 "min",
9392 "modulus",
9393 "pos",
9394 "size",
9395 "tag",
9396 "val",
9397 0
9398 };
9399
9400 const char *
9401 ada_attribute_name (enum exp_opcode n)
9402 {
9403 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9404 return attribute_names[n - OP_ATR_FIRST + 1];
9405 else
9406 return attribute_names[0];
9407 }
9408
9409 /* Evaluate the 'POS attribute applied to ARG. */
9410
9411 static LONGEST
9412 pos_atr (struct value *arg)
9413 {
9414 struct value *val = coerce_ref (arg);
9415 struct type *type = value_type (val);
9416 LONGEST result;
9417
9418 if (!discrete_type_p (type))
9419 error (_("'POS only defined on discrete types"));
9420
9421 if (!discrete_position (type, value_as_long (val), &result))
9422 error (_("enumeration value is invalid: can't find 'POS"));
9423
9424 return result;
9425 }
9426
9427 static struct value *
9428 value_pos_atr (struct type *type, struct value *arg)
9429 {
9430 return value_from_longest (type, pos_atr (arg));
9431 }
9432
9433 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9434
9435 static struct value *
9436 value_val_atr (struct type *type, struct value *arg)
9437 {
9438 if (!discrete_type_p (type))
9439 error (_("'VAL only defined on discrete types"));
9440 if (!integer_type_p (value_type (arg)))
9441 error (_("'VAL requires integral argument"));
9442
9443 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9444 {
9445 long pos = value_as_long (arg);
9446
9447 if (pos < 0 || pos >= TYPE_NFIELDS (type))
9448 error (_("argument to 'VAL out of range"));
9449 return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
9450 }
9451 else
9452 return value_from_longest (type, value_as_long (arg));
9453 }
9454
9455
9456 /* Evaluation */
9457
9458 /* True if TYPE appears to be an Ada character type.
9459 [At the moment, this is true only for Character and Wide_Character;
9460 It is a heuristic test that could stand improvement]. */
9461
9462 int
9463 ada_is_character_type (struct type *type)
9464 {
9465 const char *name;
9466
9467 /* If the type code says it's a character, then assume it really is,
9468 and don't check any further. */
9469 if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9470 return 1;
9471
9472 /* Otherwise, assume it's a character type iff it is a discrete type
9473 with a known character type name. */
9474 name = ada_type_name (type);
9475 return (name != NULL
9476 && (TYPE_CODE (type) == TYPE_CODE_INT
9477 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9478 && (strcmp (name, "character") == 0
9479 || strcmp (name, "wide_character") == 0
9480 || strcmp (name, "wide_wide_character") == 0
9481 || strcmp (name, "unsigned char") == 0));
9482 }
9483
9484 /* True if TYPE appears to be an Ada string type. */
9485
9486 int
9487 ada_is_string_type (struct type *type)
9488 {
9489 type = ada_check_typedef (type);
9490 if (type != NULL
9491 && TYPE_CODE (type) != TYPE_CODE_PTR
9492 && (ada_is_simple_array_type (type)
9493 || ada_is_array_descriptor_type (type))
9494 && ada_array_arity (type) == 1)
9495 {
9496 struct type *elttype = ada_array_element_type (type, 1);
9497
9498 return ada_is_character_type (elttype);
9499 }
9500 else
9501 return 0;
9502 }
9503
9504 /* The compiler sometimes provides a parallel XVS type for a given
9505 PAD type. Normally, it is safe to follow the PAD type directly,
9506 but older versions of the compiler have a bug that causes the offset
9507 of its "F" field to be wrong. Following that field in that case
9508 would lead to incorrect results, but this can be worked around
9509 by ignoring the PAD type and using the associated XVS type instead.
9510
9511 Set to True if the debugger should trust the contents of PAD types.
9512 Otherwise, ignore the PAD type if there is a parallel XVS type. */
9513 static int trust_pad_over_xvs = 1;
9514
9515 /* True if TYPE is a struct type introduced by the compiler to force the
9516 alignment of a value. Such types have a single field with a
9517 distinctive name. */
9518
9519 int
9520 ada_is_aligner_type (struct type *type)
9521 {
9522 type = ada_check_typedef (type);
9523
9524 if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9525 return 0;
9526
9527 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
9528 && TYPE_NFIELDS (type) == 1
9529 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
9530 }
9531
9532 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9533 the parallel type. */
9534
9535 struct type *
9536 ada_get_base_type (struct type *raw_type)
9537 {
9538 struct type *real_type_namer;
9539 struct type *raw_real_type;
9540
9541 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9542 return raw_type;
9543
9544 if (ada_is_aligner_type (raw_type))
9545 /* The encoding specifies that we should always use the aligner type.
9546 So, even if this aligner type has an associated XVS type, we should
9547 simply ignore it.
9548
9549 According to the compiler gurus, an XVS type parallel to an aligner
9550 type may exist because of a stabs limitation. In stabs, aligner
9551 types are empty because the field has a variable-sized type, and
9552 thus cannot actually be used as an aligner type. As a result,
9553 we need the associated parallel XVS type to decode the type.
9554 Since the policy in the compiler is to not change the internal
9555 representation based on the debugging info format, we sometimes
9556 end up having a redundant XVS type parallel to the aligner type. */
9557 return raw_type;
9558
9559 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9560 if (real_type_namer == NULL
9561 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9562 || TYPE_NFIELDS (real_type_namer) != 1)
9563 return raw_type;
9564
9565 if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9566 {
9567 /* This is an older encoding form where the base type needs to be
9568 looked up by name. We prefer the newer enconding because it is
9569 more efficient. */
9570 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9571 if (raw_real_type == NULL)
9572 return raw_type;
9573 else
9574 return raw_real_type;
9575 }
9576
9577 /* The field in our XVS type is a reference to the base type. */
9578 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
9579 }
9580
9581 /* The type of value designated by TYPE, with all aligners removed. */
9582
9583 struct type *
9584 ada_aligned_type (struct type *type)
9585 {
9586 if (ada_is_aligner_type (type))
9587 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9588 else
9589 return ada_get_base_type (type);
9590 }
9591
9592
9593 /* The address of the aligned value in an object at address VALADDR
9594 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9595
9596 const gdb_byte *
9597 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9598 {
9599 if (ada_is_aligner_type (type))
9600 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
9601 valaddr +
9602 TYPE_FIELD_BITPOS (type,
9603 0) / TARGET_CHAR_BIT);
9604 else
9605 return valaddr;
9606 }
9607
9608
9609
9610 /* The printed representation of an enumeration literal with encoded
9611 name NAME. The value is good to the next call of ada_enum_name. */
9612 const char *
9613 ada_enum_name (const char *name)
9614 {
9615 static char *result;
9616 static size_t result_len = 0;
9617 const char *tmp;
9618
9619 /* First, unqualify the enumeration name:
9620 1. Search for the last '.' character. If we find one, then skip
9621 all the preceding characters, the unqualified name starts
9622 right after that dot.
9623 2. Otherwise, we may be debugging on a target where the compiler
9624 translates dots into "__". Search forward for double underscores,
9625 but stop searching when we hit an overloading suffix, which is
9626 of the form "__" followed by digits. */
9627
9628 tmp = strrchr (name, '.');
9629 if (tmp != NULL)
9630 name = tmp + 1;
9631 else
9632 {
9633 while ((tmp = strstr (name, "__")) != NULL)
9634 {
9635 if (isdigit (tmp[2]))
9636 break;
9637 else
9638 name = tmp + 2;
9639 }
9640 }
9641
9642 if (name[0] == 'Q')
9643 {
9644 int v;
9645
9646 if (name[1] == 'U' || name[1] == 'W')
9647 {
9648 if (sscanf (name + 2, "%x", &v) != 1)
9649 return name;
9650 }
9651 else
9652 return name;
9653
9654 GROW_VECT (result, result_len, 16);
9655 if (isascii (v) && isprint (v))
9656 xsnprintf (result, result_len, "'%c'", v);
9657 else if (name[1] == 'U')
9658 xsnprintf (result, result_len, "[\"%02x\"]", v);
9659 else
9660 xsnprintf (result, result_len, "[\"%04x\"]", v);
9661
9662 return result;
9663 }
9664 else
9665 {
9666 tmp = strstr (name, "__");
9667 if (tmp == NULL)
9668 tmp = strstr (name, "$");
9669 if (tmp != NULL)
9670 {
9671 GROW_VECT (result, result_len, tmp - name + 1);
9672 strncpy (result, name, tmp - name);
9673 result[tmp - name] = '\0';
9674 return result;
9675 }
9676
9677 return name;
9678 }
9679 }
9680
9681 /* Evaluate the subexpression of EXP starting at *POS as for
9682 evaluate_type, updating *POS to point just past the evaluated
9683 expression. */
9684
9685 static struct value *
9686 evaluate_subexp_type (struct expression *exp, int *pos)
9687 {
9688 return evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
9689 }
9690
9691 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9692 value it wraps. */
9693
9694 static struct value *
9695 unwrap_value (struct value *val)
9696 {
9697 struct type *type = ada_check_typedef (value_type (val));
9698
9699 if (ada_is_aligner_type (type))
9700 {
9701 struct value *v = ada_value_struct_elt (val, "F", 0);
9702 struct type *val_type = ada_check_typedef (value_type (v));
9703
9704 if (ada_type_name (val_type) == NULL)
9705 TYPE_NAME (val_type) = ada_type_name (type);
9706
9707 return unwrap_value (v);
9708 }
9709 else
9710 {
9711 struct type *raw_real_type =
9712 ada_check_typedef (ada_get_base_type (type));
9713
9714 /* If there is no parallel XVS or XVE type, then the value is
9715 already unwrapped. Return it without further modification. */
9716 if ((type == raw_real_type)
9717 && ada_find_parallel_type (type, "___XVE") == NULL)
9718 return val;
9719
9720 return
9721 coerce_unspec_val_to_type
9722 (val, ada_to_fixed_type (raw_real_type, 0,
9723 value_address (val),
9724 NULL, 1));
9725 }
9726 }
9727
9728 static struct value *
9729 cast_from_fixed (struct type *type, struct value *arg)
9730 {
9731 struct value *scale = ada_scaling_factor (value_type (arg));
9732 arg = value_cast (value_type (scale), arg);
9733
9734 arg = value_binop (arg, scale, BINOP_MUL);
9735 return value_cast (type, arg);
9736 }
9737
9738 static struct value *
9739 cast_to_fixed (struct type *type, struct value *arg)
9740 {
9741 if (type == value_type (arg))
9742 return arg;
9743
9744 struct value *scale = ada_scaling_factor (type);
9745 if (ada_is_fixed_point_type (value_type (arg)))
9746 arg = cast_from_fixed (value_type (scale), arg);
9747 else
9748 arg = value_cast (value_type (scale), arg);
9749
9750 arg = value_binop (arg, scale, BINOP_DIV);
9751 return value_cast (type, arg);
9752 }
9753
9754 /* Given two array types T1 and T2, return nonzero iff both arrays
9755 contain the same number of elements. */
9756
9757 static int
9758 ada_same_array_size_p (struct type *t1, struct type *t2)
9759 {
9760 LONGEST lo1, hi1, lo2, hi2;
9761
9762 /* Get the array bounds in order to verify that the size of
9763 the two arrays match. */
9764 if (!get_array_bounds (t1, &lo1, &hi1)
9765 || !get_array_bounds (t2, &lo2, &hi2))
9766 error (_("unable to determine array bounds"));
9767
9768 /* To make things easier for size comparison, normalize a bit
9769 the case of empty arrays by making sure that the difference
9770 between upper bound and lower bound is always -1. */
9771 if (lo1 > hi1)
9772 hi1 = lo1 - 1;
9773 if (lo2 > hi2)
9774 hi2 = lo2 - 1;
9775
9776 return (hi1 - lo1 == hi2 - lo2);
9777 }
9778
9779 /* Assuming that VAL is an array of integrals, and TYPE represents
9780 an array with the same number of elements, but with wider integral
9781 elements, return an array "casted" to TYPE. In practice, this
9782 means that the returned array is built by casting each element
9783 of the original array into TYPE's (wider) element type. */
9784
9785 static struct value *
9786 ada_promote_array_of_integrals (struct type *type, struct value *val)
9787 {
9788 struct type *elt_type = TYPE_TARGET_TYPE (type);
9789 LONGEST lo, hi;
9790 struct value *res;
9791 LONGEST i;
9792
9793 /* Verify that both val and type are arrays of scalars, and
9794 that the size of val's elements is smaller than the size
9795 of type's element. */
9796 gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9797 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (type)));
9798 gdb_assert (TYPE_CODE (value_type (val)) == TYPE_CODE_ARRAY);
9799 gdb_assert (is_integral_type (TYPE_TARGET_TYPE (value_type (val))));
9800 gdb_assert (TYPE_LENGTH (TYPE_TARGET_TYPE (type))
9801 > TYPE_LENGTH (TYPE_TARGET_TYPE (value_type (val))));
9802
9803 if (!get_array_bounds (type, &lo, &hi))
9804 error (_("unable to determine array bounds"));
9805
9806 res = allocate_value (type);
9807
9808 /* Promote each array element. */
9809 for (i = 0; i < hi - lo + 1; i++)
9810 {
9811 struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9812
9813 memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9814 value_contents_all (elt), TYPE_LENGTH (elt_type));
9815 }
9816
9817 return res;
9818 }
9819
9820 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9821 return the converted value. */
9822
9823 static struct value *
9824 coerce_for_assign (struct type *type, struct value *val)
9825 {
9826 struct type *type2 = value_type (val);
9827
9828 if (type == type2)
9829 return val;
9830
9831 type2 = ada_check_typedef (type2);
9832 type = ada_check_typedef (type);
9833
9834 if (TYPE_CODE (type2) == TYPE_CODE_PTR
9835 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9836 {
9837 val = ada_value_ind (val);
9838 type2 = value_type (val);
9839 }
9840
9841 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
9842 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9843 {
9844 if (!ada_same_array_size_p (type, type2))
9845 error (_("cannot assign arrays of different length"));
9846
9847 if (is_integral_type (TYPE_TARGET_TYPE (type))
9848 && is_integral_type (TYPE_TARGET_TYPE (type2))
9849 && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9850 < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9851 {
9852 /* Allow implicit promotion of the array elements to
9853 a wider type. */
9854 return ada_promote_array_of_integrals (type, val);
9855 }
9856
9857 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9858 != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9859 error (_("Incompatible types in assignment"));
9860 deprecated_set_value_type (val, type);
9861 }
9862 return val;
9863 }
9864
9865 static struct value *
9866 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9867 {
9868 struct value *val;
9869 struct type *type1, *type2;
9870 LONGEST v, v1, v2;
9871
9872 arg1 = coerce_ref (arg1);
9873 arg2 = coerce_ref (arg2);
9874 type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9875 type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9876
9877 if (TYPE_CODE (type1) != TYPE_CODE_INT
9878 || TYPE_CODE (type2) != TYPE_CODE_INT)
9879 return value_binop (arg1, arg2, op);
9880
9881 switch (op)
9882 {
9883 case BINOP_MOD:
9884 case BINOP_DIV:
9885 case BINOP_REM:
9886 break;
9887 default:
9888 return value_binop (arg1, arg2, op);
9889 }
9890
9891 v2 = value_as_long (arg2);
9892 if (v2 == 0)
9893 error (_("second operand of %s must not be zero."), op_string (op));
9894
9895 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9896 return value_binop (arg1, arg2, op);
9897
9898 v1 = value_as_long (arg1);
9899 switch (op)
9900 {
9901 case BINOP_DIV:
9902 v = v1 / v2;
9903 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9904 v += v > 0 ? -1 : 1;
9905 break;
9906 case BINOP_REM:
9907 v = v1 % v2;
9908 if (v * v1 < 0)
9909 v -= v2;
9910 break;
9911 default:
9912 /* Should not reach this point. */
9913 v = 0;
9914 }
9915
9916 val = allocate_value (type1);
9917 store_unsigned_integer (value_contents_raw (val),
9918 TYPE_LENGTH (value_type (val)),
9919 gdbarch_byte_order (get_type_arch (type1)), v);
9920 return val;
9921 }
9922
9923 static int
9924 ada_value_equal (struct value *arg1, struct value *arg2)
9925 {
9926 if (ada_is_direct_array_type (value_type (arg1))
9927 || ada_is_direct_array_type (value_type (arg2)))
9928 {
9929 struct type *arg1_type, *arg2_type;
9930
9931 /* Automatically dereference any array reference before
9932 we attempt to perform the comparison. */
9933 arg1 = ada_coerce_ref (arg1);
9934 arg2 = ada_coerce_ref (arg2);
9935
9936 arg1 = ada_coerce_to_simple_array (arg1);
9937 arg2 = ada_coerce_to_simple_array (arg2);
9938
9939 arg1_type = ada_check_typedef (value_type (arg1));
9940 arg2_type = ada_check_typedef (value_type (arg2));
9941
9942 if (TYPE_CODE (arg1_type) != TYPE_CODE_ARRAY
9943 || TYPE_CODE (arg2_type) != TYPE_CODE_ARRAY)
9944 error (_("Attempt to compare array with non-array"));
9945 /* FIXME: The following works only for types whose
9946 representations use all bits (no padding or undefined bits)
9947 and do not have user-defined equality. */
9948 return (TYPE_LENGTH (arg1_type) == TYPE_LENGTH (arg2_type)
9949 && memcmp (value_contents (arg1), value_contents (arg2),
9950 TYPE_LENGTH (arg1_type)) == 0);
9951 }
9952 return value_equal (arg1, arg2);
9953 }
9954
9955 /* Total number of component associations in the aggregate starting at
9956 index PC in EXP. Assumes that index PC is the start of an
9957 OP_AGGREGATE. */
9958
9959 static int
9960 num_component_specs (struct expression *exp, int pc)
9961 {
9962 int n, m, i;
9963
9964 m = exp->elts[pc + 1].longconst;
9965 pc += 3;
9966 n = 0;
9967 for (i = 0; i < m; i += 1)
9968 {
9969 switch (exp->elts[pc].opcode)
9970 {
9971 default:
9972 n += 1;
9973 break;
9974 case OP_CHOICES:
9975 n += exp->elts[pc + 1].longconst;
9976 break;
9977 }
9978 ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9979 }
9980 return n;
9981 }
9982
9983 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9984 component of LHS (a simple array or a record), updating *POS past
9985 the expression, assuming that LHS is contained in CONTAINER. Does
9986 not modify the inferior's memory, nor does it modify LHS (unless
9987 LHS == CONTAINER). */
9988
9989 static void
9990 assign_component (struct value *container, struct value *lhs, LONGEST index,
9991 struct expression *exp, int *pos)
9992 {
9993 struct value *mark = value_mark ();
9994 struct value *elt;
9995 struct type *lhs_type = check_typedef (value_type (lhs));
9996
9997 if (TYPE_CODE (lhs_type) == TYPE_CODE_ARRAY)
9998 {
9999 struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
10000 struct value *index_val = value_from_longest (index_type, index);
10001
10002 elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
10003 }
10004 else
10005 {
10006 elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
10007 elt = ada_to_fixed_value (elt);
10008 }
10009
10010 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10011 assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
10012 else
10013 value_assign_to_component (container, elt,
10014 ada_evaluate_subexp (NULL, exp, pos,
10015 EVAL_NORMAL));
10016
10017 value_free_to_mark (mark);
10018 }
10019
10020 /* Assuming that LHS represents an lvalue having a record or array
10021 type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
10022 of that aggregate's value to LHS, advancing *POS past the
10023 aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
10024 lvalue containing LHS (possibly LHS itself). Does not modify
10025 the inferior's memory, nor does it modify the contents of
10026 LHS (unless == CONTAINER). Returns the modified CONTAINER. */
10027
10028 static struct value *
10029 assign_aggregate (struct value *container,
10030 struct value *lhs, struct expression *exp,
10031 int *pos, enum noside noside)
10032 {
10033 struct type *lhs_type;
10034 int n = exp->elts[*pos+1].longconst;
10035 LONGEST low_index, high_index;
10036 int num_specs;
10037 LONGEST *indices;
10038 int max_indices, num_indices;
10039 int i;
10040
10041 *pos += 3;
10042 if (noside != EVAL_NORMAL)
10043 {
10044 for (i = 0; i < n; i += 1)
10045 ada_evaluate_subexp (NULL, exp, pos, noside);
10046 return container;
10047 }
10048
10049 container = ada_coerce_ref (container);
10050 if (ada_is_direct_array_type (value_type (container)))
10051 container = ada_coerce_to_simple_array (container);
10052 lhs = ada_coerce_ref (lhs);
10053 if (!deprecated_value_modifiable (lhs))
10054 error (_("Left operand of assignment is not a modifiable lvalue."));
10055
10056 lhs_type = check_typedef (value_type (lhs));
10057 if (ada_is_direct_array_type (lhs_type))
10058 {
10059 lhs = ada_coerce_to_simple_array (lhs);
10060 lhs_type = check_typedef (value_type (lhs));
10061 low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
10062 high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
10063 }
10064 else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
10065 {
10066 low_index = 0;
10067 high_index = num_visible_fields (lhs_type) - 1;
10068 }
10069 else
10070 error (_("Left-hand side must be array or record."));
10071
10072 num_specs = num_component_specs (exp, *pos - 3);
10073 max_indices = 4 * num_specs + 4;
10074 indices = XALLOCAVEC (LONGEST, max_indices);
10075 indices[0] = indices[1] = low_index - 1;
10076 indices[2] = indices[3] = high_index + 1;
10077 num_indices = 4;
10078
10079 for (i = 0; i < n; i += 1)
10080 {
10081 switch (exp->elts[*pos].opcode)
10082 {
10083 case OP_CHOICES:
10084 aggregate_assign_from_choices (container, lhs, exp, pos, indices,
10085 &num_indices, max_indices,
10086 low_index, high_index);
10087 break;
10088 case OP_POSITIONAL:
10089 aggregate_assign_positional (container, lhs, exp, pos, indices,
10090 &num_indices, max_indices,
10091 low_index, high_index);
10092 break;
10093 case OP_OTHERS:
10094 if (i != n-1)
10095 error (_("Misplaced 'others' clause"));
10096 aggregate_assign_others (container, lhs, exp, pos, indices,
10097 num_indices, low_index, high_index);
10098 break;
10099 default:
10100 error (_("Internal error: bad aggregate clause"));
10101 }
10102 }
10103
10104 return container;
10105 }
10106
10107 /* Assign into the component of LHS indexed by the OP_POSITIONAL
10108 construct at *POS, updating *POS past the construct, given that
10109 the positions are relative to lower bound LOW, where HIGH is the
10110 upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
10111 updating *NUM_INDICES as needed. CONTAINER is as for
10112 assign_aggregate. */
10113 static void
10114 aggregate_assign_positional (struct value *container,
10115 struct value *lhs, struct expression *exp,
10116 int *pos, LONGEST *indices, int *num_indices,
10117 int max_indices, LONGEST low, LONGEST high)
10118 {
10119 LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
10120
10121 if (ind - 1 == high)
10122 warning (_("Extra components in aggregate ignored."));
10123 if (ind <= high)
10124 {
10125 add_component_interval (ind, ind, indices, num_indices, max_indices);
10126 *pos += 3;
10127 assign_component (container, lhs, ind, exp, pos);
10128 }
10129 else
10130 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10131 }
10132
10133 /* Assign into the components of LHS indexed by the OP_CHOICES
10134 construct at *POS, updating *POS past the construct, given that
10135 the allowable indices are LOW..HIGH. Record the indices assigned
10136 to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
10137 needed. CONTAINER is as for assign_aggregate. */
10138 static void
10139 aggregate_assign_from_choices (struct value *container,
10140 struct value *lhs, struct expression *exp,
10141 int *pos, LONGEST *indices, int *num_indices,
10142 int max_indices, LONGEST low, LONGEST high)
10143 {
10144 int j;
10145 int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
10146 int choice_pos, expr_pc;
10147 int is_array = ada_is_direct_array_type (value_type (lhs));
10148
10149 choice_pos = *pos += 3;
10150
10151 for (j = 0; j < n_choices; j += 1)
10152 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10153 expr_pc = *pos;
10154 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10155
10156 for (j = 0; j < n_choices; j += 1)
10157 {
10158 LONGEST lower, upper;
10159 enum exp_opcode op = exp->elts[choice_pos].opcode;
10160
10161 if (op == OP_DISCRETE_RANGE)
10162 {
10163 choice_pos += 1;
10164 lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10165 EVAL_NORMAL));
10166 upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
10167 EVAL_NORMAL));
10168 }
10169 else if (is_array)
10170 {
10171 lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
10172 EVAL_NORMAL));
10173 upper = lower;
10174 }
10175 else
10176 {
10177 int ind;
10178 const char *name;
10179
10180 switch (op)
10181 {
10182 case OP_NAME:
10183 name = &exp->elts[choice_pos + 2].string;
10184 break;
10185 case OP_VAR_VALUE:
10186 name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
10187 break;
10188 default:
10189 error (_("Invalid record component association."));
10190 }
10191 ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
10192 ind = 0;
10193 if (! find_struct_field (name, value_type (lhs), 0,
10194 NULL, NULL, NULL, NULL, &ind))
10195 error (_("Unknown component name: %s."), name);
10196 lower = upper = ind;
10197 }
10198
10199 if (lower <= upper && (lower < low || upper > high))
10200 error (_("Index in component association out of bounds."));
10201
10202 add_component_interval (lower, upper, indices, num_indices,
10203 max_indices);
10204 while (lower <= upper)
10205 {
10206 int pos1;
10207
10208 pos1 = expr_pc;
10209 assign_component (container, lhs, lower, exp, &pos1);
10210 lower += 1;
10211 }
10212 }
10213 }
10214
10215 /* Assign the value of the expression in the OP_OTHERS construct in
10216 EXP at *POS into the components of LHS indexed from LOW .. HIGH that
10217 have not been previously assigned. The index intervals already assigned
10218 are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
10219 OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
10220 static void
10221 aggregate_assign_others (struct value *container,
10222 struct value *lhs, struct expression *exp,
10223 int *pos, LONGEST *indices, int num_indices,
10224 LONGEST low, LONGEST high)
10225 {
10226 int i;
10227 int expr_pc = *pos + 1;
10228
10229 for (i = 0; i < num_indices - 2; i += 2)
10230 {
10231 LONGEST ind;
10232
10233 for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
10234 {
10235 int localpos;
10236
10237 localpos = expr_pc;
10238 assign_component (container, lhs, ind, exp, &localpos);
10239 }
10240 }
10241 ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
10242 }
10243
10244 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
10245 [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
10246 modifying *SIZE as needed. It is an error if *SIZE exceeds
10247 MAX_SIZE. The resulting intervals do not overlap. */
10248 static void
10249 add_component_interval (LONGEST low, LONGEST high,
10250 LONGEST* indices, int *size, int max_size)
10251 {
10252 int i, j;
10253
10254 for (i = 0; i < *size; i += 2) {
10255 if (high >= indices[i] && low <= indices[i + 1])
10256 {
10257 int kh;
10258
10259 for (kh = i + 2; kh < *size; kh += 2)
10260 if (high < indices[kh])
10261 break;
10262 if (low < indices[i])
10263 indices[i] = low;
10264 indices[i + 1] = indices[kh - 1];
10265 if (high > indices[i + 1])
10266 indices[i + 1] = high;
10267 memcpy (indices + i + 2, indices + kh, *size - kh);
10268 *size -= kh - i - 2;
10269 return;
10270 }
10271 else if (high < indices[i])
10272 break;
10273 }
10274
10275 if (*size == max_size)
10276 error (_("Internal error: miscounted aggregate components."));
10277 *size += 2;
10278 for (j = *size-1; j >= i+2; j -= 1)
10279 indices[j] = indices[j - 2];
10280 indices[i] = low;
10281 indices[i + 1] = high;
10282 }
10283
10284 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
10285 is different. */
10286
10287 static struct value *
10288 ada_value_cast (struct type *type, struct value *arg2)
10289 {
10290 if (type == ada_check_typedef (value_type (arg2)))
10291 return arg2;
10292
10293 if (ada_is_fixed_point_type (type))
10294 return (cast_to_fixed (type, arg2));
10295
10296 if (ada_is_fixed_point_type (value_type (arg2)))
10297 return cast_from_fixed (type, arg2);
10298
10299 return value_cast (type, arg2);
10300 }
10301
10302 /* Evaluating Ada expressions, and printing their result.
10303 ------------------------------------------------------
10304
10305 1. Introduction:
10306 ----------------
10307
10308 We usually evaluate an Ada expression in order to print its value.
10309 We also evaluate an expression in order to print its type, which
10310 happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
10311 but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
10312 EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
10313 the evaluation compared to the EVAL_NORMAL, but is otherwise very
10314 similar.
10315
10316 Evaluating expressions is a little more complicated for Ada entities
10317 than it is for entities in languages such as C. The main reason for
10318 this is that Ada provides types whose definition might be dynamic.
10319 One example of such types is variant records. Or another example
10320 would be an array whose bounds can only be known at run time.
10321
10322 The following description is a general guide as to what should be
10323 done (and what should NOT be done) in order to evaluate an expression
10324 involving such types, and when. This does not cover how the semantic
10325 information is encoded by GNAT as this is covered separatly. For the
10326 document used as the reference for the GNAT encoding, see exp_dbug.ads
10327 in the GNAT sources.
10328
10329 Ideally, we should embed each part of this description next to its
10330 associated code. Unfortunately, the amount of code is so vast right
10331 now that it's hard to see whether the code handling a particular
10332 situation might be duplicated or not. One day, when the code is
10333 cleaned up, this guide might become redundant with the comments
10334 inserted in the code, and we might want to remove it.
10335
10336 2. ``Fixing'' an Entity, the Simple Case:
10337 -----------------------------------------
10338
10339 When evaluating Ada expressions, the tricky issue is that they may
10340 reference entities whose type contents and size are not statically
10341 known. Consider for instance a variant record:
10342
10343 type Rec (Empty : Boolean := True) is record
10344 case Empty is
10345 when True => null;
10346 when False => Value : Integer;
10347 end case;
10348 end record;
10349 Yes : Rec := (Empty => False, Value => 1);
10350 No : Rec := (empty => True);
10351
10352 The size and contents of that record depends on the value of the
10353 descriminant (Rec.Empty). At this point, neither the debugging
10354 information nor the associated type structure in GDB are able to
10355 express such dynamic types. So what the debugger does is to create
10356 "fixed" versions of the type that applies to the specific object.
10357 We also informally refer to this opperation as "fixing" an object,
10358 which means creating its associated fixed type.
10359
10360 Example: when printing the value of variable "Yes" above, its fixed
10361 type would look like this:
10362
10363 type Rec is record
10364 Empty : Boolean;
10365 Value : Integer;
10366 end record;
10367
10368 On the other hand, if we printed the value of "No", its fixed type
10369 would become:
10370
10371 type Rec is record
10372 Empty : Boolean;
10373 end record;
10374
10375 Things become a little more complicated when trying to fix an entity
10376 with a dynamic type that directly contains another dynamic type,
10377 such as an array of variant records, for instance. There are
10378 two possible cases: Arrays, and records.
10379
10380 3. ``Fixing'' Arrays:
10381 ---------------------
10382
10383 The type structure in GDB describes an array in terms of its bounds,
10384 and the type of its elements. By design, all elements in the array
10385 have the same type and we cannot represent an array of variant elements
10386 using the current type structure in GDB. When fixing an array,
10387 we cannot fix the array element, as we would potentially need one
10388 fixed type per element of the array. As a result, the best we can do
10389 when fixing an array is to produce an array whose bounds and size
10390 are correct (allowing us to read it from memory), but without having
10391 touched its element type. Fixing each element will be done later,
10392 when (if) necessary.
10393
10394 Arrays are a little simpler to handle than records, because the same
10395 amount of memory is allocated for each element of the array, even if
10396 the amount of space actually used by each element differs from element
10397 to element. Consider for instance the following array of type Rec:
10398
10399 type Rec_Array is array (1 .. 2) of Rec;
10400
10401 The actual amount of memory occupied by each element might be different
10402 from element to element, depending on the value of their discriminant.
10403 But the amount of space reserved for each element in the array remains
10404 fixed regardless. So we simply need to compute that size using
10405 the debugging information available, from which we can then determine
10406 the array size (we multiply the number of elements of the array by
10407 the size of each element).
10408
10409 The simplest case is when we have an array of a constrained element
10410 type. For instance, consider the following type declarations:
10411
10412 type Bounded_String (Max_Size : Integer) is
10413 Length : Integer;
10414 Buffer : String (1 .. Max_Size);
10415 end record;
10416 type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10417
10418 In this case, the compiler describes the array as an array of
10419 variable-size elements (identified by its XVS suffix) for which
10420 the size can be read in the parallel XVZ variable.
10421
10422 In the case of an array of an unconstrained element type, the compiler
10423 wraps the array element inside a private PAD type. This type should not
10424 be shown to the user, and must be "unwrap"'ed before printing. Note
10425 that we also use the adjective "aligner" in our code to designate
10426 these wrapper types.
10427
10428 In some cases, the size allocated for each element is statically
10429 known. In that case, the PAD type already has the correct size,
10430 and the array element should remain unfixed.
10431
10432 But there are cases when this size is not statically known.
10433 For instance, assuming that "Five" is an integer variable:
10434
10435 type Dynamic is array (1 .. Five) of Integer;
10436 type Wrapper (Has_Length : Boolean := False) is record
10437 Data : Dynamic;
10438 case Has_Length is
10439 when True => Length : Integer;
10440 when False => null;
10441 end case;
10442 end record;
10443 type Wrapper_Array is array (1 .. 2) of Wrapper;
10444
10445 Hello : Wrapper_Array := (others => (Has_Length => True,
10446 Data => (others => 17),
10447 Length => 1));
10448
10449
10450 The debugging info would describe variable Hello as being an
10451 array of a PAD type. The size of that PAD type is not statically
10452 known, but can be determined using a parallel XVZ variable.
10453 In that case, a copy of the PAD type with the correct size should
10454 be used for the fixed array.
10455
10456 3. ``Fixing'' record type objects:
10457 ----------------------------------
10458
10459 Things are slightly different from arrays in the case of dynamic
10460 record types. In this case, in order to compute the associated
10461 fixed type, we need to determine the size and offset of each of
10462 its components. This, in turn, requires us to compute the fixed
10463 type of each of these components.
10464
10465 Consider for instance the example:
10466
10467 type Bounded_String (Max_Size : Natural) is record
10468 Str : String (1 .. Max_Size);
10469 Length : Natural;
10470 end record;
10471 My_String : Bounded_String (Max_Size => 10);
10472
10473 In that case, the position of field "Length" depends on the size
10474 of field Str, which itself depends on the value of the Max_Size
10475 discriminant. In order to fix the type of variable My_String,
10476 we need to fix the type of field Str. Therefore, fixing a variant
10477 record requires us to fix each of its components.
10478
10479 However, if a component does not have a dynamic size, the component
10480 should not be fixed. In particular, fields that use a PAD type
10481 should not fixed. Here is an example where this might happen
10482 (assuming type Rec above):
10483
10484 type Container (Big : Boolean) is record
10485 First : Rec;
10486 After : Integer;
10487 case Big is
10488 when True => Another : Integer;
10489 when False => null;
10490 end case;
10491 end record;
10492 My_Container : Container := (Big => False,
10493 First => (Empty => True),
10494 After => 42);
10495
10496 In that example, the compiler creates a PAD type for component First,
10497 whose size is constant, and then positions the component After just
10498 right after it. The offset of component After is therefore constant
10499 in this case.
10500
10501 The debugger computes the position of each field based on an algorithm
10502 that uses, among other things, the actual position and size of the field
10503 preceding it. Let's now imagine that the user is trying to print
10504 the value of My_Container. If the type fixing was recursive, we would
10505 end up computing the offset of field After based on the size of the
10506 fixed version of field First. And since in our example First has
10507 only one actual field, the size of the fixed type is actually smaller
10508 than the amount of space allocated to that field, and thus we would
10509 compute the wrong offset of field After.
10510
10511 To make things more complicated, we need to watch out for dynamic
10512 components of variant records (identified by the ___XVL suffix in
10513 the component name). Even if the target type is a PAD type, the size
10514 of that type might not be statically known. So the PAD type needs
10515 to be unwrapped and the resulting type needs to be fixed. Otherwise,
10516 we might end up with the wrong size for our component. This can be
10517 observed with the following type declarations:
10518
10519 type Octal is new Integer range 0 .. 7;
10520 type Octal_Array is array (Positive range <>) of Octal;
10521 pragma Pack (Octal_Array);
10522
10523 type Octal_Buffer (Size : Positive) is record
10524 Buffer : Octal_Array (1 .. Size);
10525 Length : Integer;
10526 end record;
10527
10528 In that case, Buffer is a PAD type whose size is unset and needs
10529 to be computed by fixing the unwrapped type.
10530
10531 4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10532 ----------------------------------------------------------
10533
10534 Lastly, when should the sub-elements of an entity that remained unfixed
10535 thus far, be actually fixed?
10536
10537 The answer is: Only when referencing that element. For instance
10538 when selecting one component of a record, this specific component
10539 should be fixed at that point in time. Or when printing the value
10540 of a record, each component should be fixed before its value gets
10541 printed. Similarly for arrays, the element of the array should be
10542 fixed when printing each element of the array, or when extracting
10543 one element out of that array. On the other hand, fixing should
10544 not be performed on the elements when taking a slice of an array!
10545
10546 Note that one of the side effects of miscomputing the offset and
10547 size of each field is that we end up also miscomputing the size
10548 of the containing type. This can have adverse results when computing
10549 the value of an entity. GDB fetches the value of an entity based
10550 on the size of its type, and thus a wrong size causes GDB to fetch
10551 the wrong amount of memory. In the case where the computed size is
10552 too small, GDB fetches too little data to print the value of our
10553 entity. Results in this case are unpredictable, as we usually read
10554 past the buffer containing the data =:-o. */
10555
10556 /* Evaluate a subexpression of EXP, at index *POS, and return a value
10557 for that subexpression cast to TO_TYPE. Advance *POS over the
10558 subexpression. */
10559
10560 static value *
10561 ada_evaluate_subexp_for_cast (expression *exp, int *pos,
10562 enum noside noside, struct type *to_type)
10563 {
10564 int pc = *pos;
10565
10566 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE
10567 || exp->elts[pc].opcode == OP_VAR_VALUE)
10568 {
10569 (*pos) += 4;
10570
10571 value *val;
10572 if (exp->elts[pc].opcode == OP_VAR_MSYM_VALUE)
10573 {
10574 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10575 return value_zero (to_type, not_lval);
10576
10577 val = evaluate_var_msym_value (noside,
10578 exp->elts[pc + 1].objfile,
10579 exp->elts[pc + 2].msymbol);
10580 }
10581 else
10582 val = evaluate_var_value (noside,
10583 exp->elts[pc + 1].block,
10584 exp->elts[pc + 2].symbol);
10585
10586 if (noside == EVAL_SKIP)
10587 return eval_skip_value (exp);
10588
10589 val = ada_value_cast (to_type, val);
10590
10591 /* Follow the Ada language semantics that do not allow taking
10592 an address of the result of a cast (view conversion in Ada). */
10593 if (VALUE_LVAL (val) == lval_memory)
10594 {
10595 if (value_lazy (val))
10596 value_fetch_lazy (val);
10597 VALUE_LVAL (val) = not_lval;
10598 }
10599 return val;
10600 }
10601
10602 value *val = evaluate_subexp (to_type, exp, pos, noside);
10603 if (noside == EVAL_SKIP)
10604 return eval_skip_value (exp);
10605 return ada_value_cast (to_type, val);
10606 }
10607
10608 /* Implement the evaluate_exp routine in the exp_descriptor structure
10609 for the Ada language. */
10610
10611 static struct value *
10612 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
10613 int *pos, enum noside noside)
10614 {
10615 enum exp_opcode op;
10616 int tem;
10617 int pc;
10618 int preeval_pos;
10619 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10620 struct type *type;
10621 int nargs, oplen;
10622 struct value **argvec;
10623
10624 pc = *pos;
10625 *pos += 1;
10626 op = exp->elts[pc].opcode;
10627
10628 switch (op)
10629 {
10630 default:
10631 *pos -= 1;
10632 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10633
10634 if (noside == EVAL_NORMAL)
10635 arg1 = unwrap_value (arg1);
10636
10637 /* If evaluating an OP_FLOAT and an EXPECT_TYPE was provided,
10638 then we need to perform the conversion manually, because
10639 evaluate_subexp_standard doesn't do it. This conversion is
10640 necessary in Ada because the different kinds of float/fixed
10641 types in Ada have different representations.
10642
10643 Similarly, we need to perform the conversion from OP_LONG
10644 ourselves. */
10645 if ((op == OP_FLOAT || op == OP_LONG) && expect_type != NULL)
10646 arg1 = ada_value_cast (expect_type, arg1);
10647
10648 return arg1;
10649
10650 case OP_STRING:
10651 {
10652 struct value *result;
10653
10654 *pos -= 1;
10655 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10656 /* The result type will have code OP_STRING, bashed there from
10657 OP_ARRAY. Bash it back. */
10658 if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10659 TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
10660 return result;
10661 }
10662
10663 case UNOP_CAST:
10664 (*pos) += 2;
10665 type = exp->elts[pc + 1].type;
10666 return ada_evaluate_subexp_for_cast (exp, pos, noside, type);
10667
10668 case UNOP_QUAL:
10669 (*pos) += 2;
10670 type = exp->elts[pc + 1].type;
10671 return ada_evaluate_subexp (type, exp, pos, noside);
10672
10673 case BINOP_ASSIGN:
10674 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10675 if (exp->elts[*pos].opcode == OP_AGGREGATE)
10676 {
10677 arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10678 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10679 return arg1;
10680 return ada_value_assign (arg1, arg1);
10681 }
10682 /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10683 except if the lhs of our assignment is a convenience variable.
10684 In the case of assigning to a convenience variable, the lhs
10685 should be exactly the result of the evaluation of the rhs. */
10686 type = value_type (arg1);
10687 if (VALUE_LVAL (arg1) == lval_internalvar)
10688 type = NULL;
10689 arg2 = evaluate_subexp (type, exp, pos, noside);
10690 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10691 return arg1;
10692 if (ada_is_fixed_point_type (value_type (arg1)))
10693 arg2 = cast_to_fixed (value_type (arg1), arg2);
10694 else if (ada_is_fixed_point_type (value_type (arg2)))
10695 error
10696 (_("Fixed-point values must be assigned to fixed-point variables"));
10697 else
10698 arg2 = coerce_for_assign (value_type (arg1), arg2);
10699 return ada_value_assign (arg1, arg2);
10700
10701 case BINOP_ADD:
10702 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10703 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10704 if (noside == EVAL_SKIP)
10705 goto nosideret;
10706 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10707 return (value_from_longest
10708 (value_type (arg1),
10709 value_as_long (arg1) + value_as_long (arg2)));
10710 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10711 return (value_from_longest
10712 (value_type (arg2),
10713 value_as_long (arg1) + value_as_long (arg2)));
10714 if ((ada_is_fixed_point_type (value_type (arg1))
10715 || ada_is_fixed_point_type (value_type (arg2)))
10716 && value_type (arg1) != value_type (arg2))
10717 error (_("Operands of fixed-point addition must have the same type"));
10718 /* Do the addition, and cast the result to the type of the first
10719 argument. We cannot cast the result to a reference type, so if
10720 ARG1 is a reference type, find its underlying type. */
10721 type = value_type (arg1);
10722 while (TYPE_CODE (type) == TYPE_CODE_REF)
10723 type = TYPE_TARGET_TYPE (type);
10724 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10725 return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
10726
10727 case BINOP_SUB:
10728 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10729 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10730 if (noside == EVAL_SKIP)
10731 goto nosideret;
10732 if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10733 return (value_from_longest
10734 (value_type (arg1),
10735 value_as_long (arg1) - value_as_long (arg2)));
10736 if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10737 return (value_from_longest
10738 (value_type (arg2),
10739 value_as_long (arg1) - value_as_long (arg2)));
10740 if ((ada_is_fixed_point_type (value_type (arg1))
10741 || ada_is_fixed_point_type (value_type (arg2)))
10742 && value_type (arg1) != value_type (arg2))
10743 error (_("Operands of fixed-point subtraction "
10744 "must have the same type"));
10745 /* Do the substraction, and cast the result to the type of the first
10746 argument. We cannot cast the result to a reference type, so if
10747 ARG1 is a reference type, find its underlying type. */
10748 type = value_type (arg1);
10749 while (TYPE_CODE (type) == TYPE_CODE_REF)
10750 type = TYPE_TARGET_TYPE (type);
10751 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10752 return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
10753
10754 case BINOP_MUL:
10755 case BINOP_DIV:
10756 case BINOP_REM:
10757 case BINOP_MOD:
10758 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10759 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10760 if (noside == EVAL_SKIP)
10761 goto nosideret;
10762 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10763 {
10764 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10765 return value_zero (value_type (arg1), not_lval);
10766 }
10767 else
10768 {
10769 type = builtin_type (exp->gdbarch)->builtin_double;
10770 if (ada_is_fixed_point_type (value_type (arg1)))
10771 arg1 = cast_from_fixed (type, arg1);
10772 if (ada_is_fixed_point_type (value_type (arg2)))
10773 arg2 = cast_from_fixed (type, arg2);
10774 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10775 return ada_value_binop (arg1, arg2, op);
10776 }
10777
10778 case BINOP_EQUAL:
10779 case BINOP_NOTEQUAL:
10780 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10781 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
10782 if (noside == EVAL_SKIP)
10783 goto nosideret;
10784 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10785 tem = 0;
10786 else
10787 {
10788 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10789 tem = ada_value_equal (arg1, arg2);
10790 }
10791 if (op == BINOP_NOTEQUAL)
10792 tem = !tem;
10793 type = language_bool_type (exp->language_defn, exp->gdbarch);
10794 return value_from_longest (type, (LONGEST) tem);
10795
10796 case UNOP_NEG:
10797 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10798 if (noside == EVAL_SKIP)
10799 goto nosideret;
10800 else if (ada_is_fixed_point_type (value_type (arg1)))
10801 return value_cast (value_type (arg1), value_neg (arg1));
10802 else
10803 {
10804 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10805 return value_neg (arg1);
10806 }
10807
10808 case BINOP_LOGICAL_AND:
10809 case BINOP_LOGICAL_OR:
10810 case UNOP_LOGICAL_NOT:
10811 {
10812 struct value *val;
10813
10814 *pos -= 1;
10815 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10816 type = language_bool_type (exp->language_defn, exp->gdbarch);
10817 return value_cast (type, val);
10818 }
10819
10820 case BINOP_BITWISE_AND:
10821 case BINOP_BITWISE_IOR:
10822 case BINOP_BITWISE_XOR:
10823 {
10824 struct value *val;
10825
10826 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
10827 *pos = pc;
10828 val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10829
10830 return value_cast (value_type (arg1), val);
10831 }
10832
10833 case OP_VAR_VALUE:
10834 *pos -= 1;
10835
10836 if (noside == EVAL_SKIP)
10837 {
10838 *pos += 4;
10839 goto nosideret;
10840 }
10841
10842 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
10843 /* Only encountered when an unresolved symbol occurs in a
10844 context other than a function call, in which case, it is
10845 invalid. */
10846 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10847 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
10848
10849 if (noside == EVAL_AVOID_SIDE_EFFECTS)
10850 {
10851 type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
10852 /* Check to see if this is a tagged type. We also need to handle
10853 the case where the type is a reference to a tagged type, but
10854 we have to be careful to exclude pointers to tagged types.
10855 The latter should be shown as usual (as a pointer), whereas
10856 a reference should mostly be transparent to the user. */
10857 if (ada_is_tagged_type (type, 0)
10858 || (TYPE_CODE (type) == TYPE_CODE_REF
10859 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10860 {
10861 /* Tagged types are a little special in the fact that the real
10862 type is dynamic and can only be determined by inspecting the
10863 object's tag. This means that we need to get the object's
10864 value first (EVAL_NORMAL) and then extract the actual object
10865 type from its tag.
10866
10867 Note that we cannot skip the final step where we extract
10868 the object type from its tag, because the EVAL_NORMAL phase
10869 results in dynamic components being resolved into fixed ones.
10870 This can cause problems when trying to print the type
10871 description of tagged types whose parent has a dynamic size:
10872 We use the type name of the "_parent" component in order
10873 to print the name of the ancestor type in the type description.
10874 If that component had a dynamic size, the resolution into
10875 a fixed type would result in the loss of that type name,
10876 thus preventing us from printing the name of the ancestor
10877 type in the type description. */
10878 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10879
10880 if (TYPE_CODE (type) != TYPE_CODE_REF)
10881 {
10882 struct type *actual_type;
10883
10884 actual_type = type_from_tag (ada_value_tag (arg1));
10885 if (actual_type == NULL)
10886 /* If, for some reason, we were unable to determine
10887 the actual type from the tag, then use the static
10888 approximation that we just computed as a fallback.
10889 This can happen if the debugging information is
10890 incomplete, for instance. */
10891 actual_type = type;
10892 return value_zero (actual_type, not_lval);
10893 }
10894 else
10895 {
10896 /* In the case of a ref, ada_coerce_ref takes care
10897 of determining the actual type. But the evaluation
10898 should return a ref as it should be valid to ask
10899 for its address; so rebuild a ref after coerce. */
10900 arg1 = ada_coerce_ref (arg1);
10901 return value_ref (arg1, TYPE_CODE_REF);
10902 }
10903 }
10904
10905 /* Records and unions for which GNAT encodings have been
10906 generated need to be statically fixed as well.
10907 Otherwise, non-static fixing produces a type where
10908 all dynamic properties are removed, which prevents "ptype"
10909 from being able to completely describe the type.
10910 For instance, a case statement in a variant record would be
10911 replaced by the relevant components based on the actual
10912 value of the discriminants. */
10913 if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10914 && dynamic_template_type (type) != NULL)
10915 || (TYPE_CODE (type) == TYPE_CODE_UNION
10916 && ada_find_parallel_type (type, "___XVU") != NULL))
10917 {
10918 *pos += 4;
10919 return value_zero (to_static_fixed_type (type), not_lval);
10920 }
10921 }
10922
10923 arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10924 return ada_to_fixed_value (arg1);
10925
10926 case OP_FUNCALL:
10927 (*pos) += 2;
10928
10929 /* Allocate arg vector, including space for the function to be
10930 called in argvec[0] and a terminating NULL. */
10931 nargs = longest_to_int (exp->elts[pc + 1].longconst);
10932 argvec = XALLOCAVEC (struct value *, nargs + 2);
10933
10934 if (exp->elts[*pos].opcode == OP_VAR_VALUE
10935 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
10936 error (_("Unexpected unresolved symbol, %s, during evaluation"),
10937 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10938 else
10939 {
10940 for (tem = 0; tem <= nargs; tem += 1)
10941 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10942 argvec[tem] = 0;
10943
10944 if (noside == EVAL_SKIP)
10945 goto nosideret;
10946 }
10947
10948 if (ada_is_constrained_packed_array_type
10949 (desc_base_type (value_type (argvec[0]))))
10950 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
10951 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10952 && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10953 /* This is a packed array that has already been fixed, and
10954 therefore already coerced to a simple array. Nothing further
10955 to do. */
10956 ;
10957 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF)
10958 {
10959 /* Make sure we dereference references so that all the code below
10960 feels like it's really handling the referenced value. Wrapping
10961 types (for alignment) may be there, so make sure we strip them as
10962 well. */
10963 argvec[0] = ada_to_fixed_value (coerce_ref (argvec[0]));
10964 }
10965 else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10966 && VALUE_LVAL (argvec[0]) == lval_memory)
10967 argvec[0] = value_addr (argvec[0]);
10968
10969 type = ada_check_typedef (value_type (argvec[0]));
10970
10971 /* Ada allows us to implicitly dereference arrays when subscripting
10972 them. So, if this is an array typedef (encoding use for array
10973 access types encoded as fat pointers), strip it now. */
10974 if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10975 type = ada_typedef_target_type (type);
10976
10977 if (TYPE_CODE (type) == TYPE_CODE_PTR)
10978 {
10979 switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
10980 {
10981 case TYPE_CODE_FUNC:
10982 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10983 break;
10984 case TYPE_CODE_ARRAY:
10985 break;
10986 case TYPE_CODE_STRUCT:
10987 if (noside != EVAL_AVOID_SIDE_EFFECTS)
10988 argvec[0] = ada_value_ind (argvec[0]);
10989 type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10990 break;
10991 default:
10992 error (_("cannot subscript or call something of type `%s'"),
10993 ada_type_name (value_type (argvec[0])));
10994 break;
10995 }
10996 }
10997
10998 switch (TYPE_CODE (type))
10999 {
11000 case TYPE_CODE_FUNC:
11001 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11002 {
11003 if (TYPE_TARGET_TYPE (type) == NULL)
11004 error_call_unknown_return_type (NULL);
11005 return allocate_value (TYPE_TARGET_TYPE (type));
11006 }
11007 return call_function_by_hand (argvec[0], NULL, nargs, argvec + 1);
11008 case TYPE_CODE_INTERNAL_FUNCTION:
11009 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11010 /* We don't know anything about what the internal
11011 function might return, but we have to return
11012 something. */
11013 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11014 not_lval);
11015 else
11016 return call_internal_function (exp->gdbarch, exp->language_defn,
11017 argvec[0], nargs, argvec + 1);
11018
11019 case TYPE_CODE_STRUCT:
11020 {
11021 int arity;
11022
11023 arity = ada_array_arity (type);
11024 type = ada_array_element_type (type, nargs);
11025 if (type == NULL)
11026 error (_("cannot subscript or call a record"));
11027 if (arity != nargs)
11028 error (_("wrong number of subscripts; expecting %d"), arity);
11029 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11030 return value_zero (ada_aligned_type (type), lval_memory);
11031 return
11032 unwrap_value (ada_value_subscript
11033 (argvec[0], nargs, argvec + 1));
11034 }
11035 case TYPE_CODE_ARRAY:
11036 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11037 {
11038 type = ada_array_element_type (type, nargs);
11039 if (type == NULL)
11040 error (_("element type of array unknown"));
11041 else
11042 return value_zero (ada_aligned_type (type), lval_memory);
11043 }
11044 return
11045 unwrap_value (ada_value_subscript
11046 (ada_coerce_to_simple_array (argvec[0]),
11047 nargs, argvec + 1));
11048 case TYPE_CODE_PTR: /* Pointer to array */
11049 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11050 {
11051 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
11052 type = ada_array_element_type (type, nargs);
11053 if (type == NULL)
11054 error (_("element type of array unknown"));
11055 else
11056 return value_zero (ada_aligned_type (type), lval_memory);
11057 }
11058 return
11059 unwrap_value (ada_value_ptr_subscript (argvec[0],
11060 nargs, argvec + 1));
11061
11062 default:
11063 error (_("Attempt to index or call something other than an "
11064 "array or function"));
11065 }
11066
11067 case TERNOP_SLICE:
11068 {
11069 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11070 struct value *low_bound_val =
11071 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11072 struct value *high_bound_val =
11073 evaluate_subexp (NULL_TYPE, exp, pos, noside);
11074 LONGEST low_bound;
11075 LONGEST high_bound;
11076
11077 low_bound_val = coerce_ref (low_bound_val);
11078 high_bound_val = coerce_ref (high_bound_val);
11079 low_bound = value_as_long (low_bound_val);
11080 high_bound = value_as_long (high_bound_val);
11081
11082 if (noside == EVAL_SKIP)
11083 goto nosideret;
11084
11085 /* If this is a reference to an aligner type, then remove all
11086 the aligners. */
11087 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11088 && ada_is_aligner_type (TYPE_TARGET_TYPE (value_type (array))))
11089 TYPE_TARGET_TYPE (value_type (array)) =
11090 ada_aligned_type (TYPE_TARGET_TYPE (value_type (array)));
11091
11092 if (ada_is_constrained_packed_array_type (value_type (array)))
11093 error (_("cannot slice a packed array"));
11094
11095 /* If this is a reference to an array or an array lvalue,
11096 convert to a pointer. */
11097 if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
11098 || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
11099 && VALUE_LVAL (array) == lval_memory))
11100 array = value_addr (array);
11101
11102 if (noside == EVAL_AVOID_SIDE_EFFECTS
11103 && ada_is_array_descriptor_type (ada_check_typedef
11104 (value_type (array))))
11105 return empty_array (ada_type_of_array (array, 0), low_bound);
11106
11107 array = ada_coerce_to_simple_array_ptr (array);
11108
11109 /* If we have more than one level of pointer indirection,
11110 dereference the value until we get only one level. */
11111 while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
11112 && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
11113 == TYPE_CODE_PTR))
11114 array = value_ind (array);
11115
11116 /* Make sure we really do have an array type before going further,
11117 to avoid a SEGV when trying to get the index type or the target
11118 type later down the road if the debug info generated by
11119 the compiler is incorrect or incomplete. */
11120 if (!ada_is_simple_array_type (value_type (array)))
11121 error (_("cannot take slice of non-array"));
11122
11123 if (TYPE_CODE (ada_check_typedef (value_type (array)))
11124 == TYPE_CODE_PTR)
11125 {
11126 struct type *type0 = ada_check_typedef (value_type (array));
11127
11128 if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
11129 return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
11130 else
11131 {
11132 struct type *arr_type0 =
11133 to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
11134
11135 return ada_value_slice_from_ptr (array, arr_type0,
11136 longest_to_int (low_bound),
11137 longest_to_int (high_bound));
11138 }
11139 }
11140 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11141 return array;
11142 else if (high_bound < low_bound)
11143 return empty_array (value_type (array), low_bound);
11144 else
11145 return ada_value_slice (array, longest_to_int (low_bound),
11146 longest_to_int (high_bound));
11147 }
11148
11149 case UNOP_IN_RANGE:
11150 (*pos) += 2;
11151 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11152 type = check_typedef (exp->elts[pc + 1].type);
11153
11154 if (noside == EVAL_SKIP)
11155 goto nosideret;
11156
11157 switch (TYPE_CODE (type))
11158 {
11159 default:
11160 lim_warning (_("Membership test incompletely implemented; "
11161 "always returns true"));
11162 type = language_bool_type (exp->language_defn, exp->gdbarch);
11163 return value_from_longest (type, (LONGEST) 1);
11164
11165 case TYPE_CODE_RANGE:
11166 arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
11167 arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
11168 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11169 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11170 type = language_bool_type (exp->language_defn, exp->gdbarch);
11171 return
11172 value_from_longest (type,
11173 (value_less (arg1, arg3)
11174 || value_equal (arg1, arg3))
11175 && (value_less (arg2, arg1)
11176 || value_equal (arg2, arg1)));
11177 }
11178
11179 case BINOP_IN_BOUNDS:
11180 (*pos) += 2;
11181 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11182 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11183
11184 if (noside == EVAL_SKIP)
11185 goto nosideret;
11186
11187 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11188 {
11189 type = language_bool_type (exp->language_defn, exp->gdbarch);
11190 return value_zero (type, not_lval);
11191 }
11192
11193 tem = longest_to_int (exp->elts[pc + 1].longconst);
11194
11195 type = ada_index_type (value_type (arg2), tem, "range");
11196 if (!type)
11197 type = value_type (arg1);
11198
11199 arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
11200 arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
11201
11202 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11203 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11204 type = language_bool_type (exp->language_defn, exp->gdbarch);
11205 return
11206 value_from_longest (type,
11207 (value_less (arg1, arg3)
11208 || value_equal (arg1, arg3))
11209 && (value_less (arg2, arg1)
11210 || value_equal (arg2, arg1)));
11211
11212 case TERNOP_IN_RANGE:
11213 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11214 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11215 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11216
11217 if (noside == EVAL_SKIP)
11218 goto nosideret;
11219
11220 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11221 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
11222 type = language_bool_type (exp->language_defn, exp->gdbarch);
11223 return
11224 value_from_longest (type,
11225 (value_less (arg1, arg3)
11226 || value_equal (arg1, arg3))
11227 && (value_less (arg2, arg1)
11228 || value_equal (arg2, arg1)));
11229
11230 case OP_ATR_FIRST:
11231 case OP_ATR_LAST:
11232 case OP_ATR_LENGTH:
11233 {
11234 struct type *type_arg;
11235
11236 if (exp->elts[*pos].opcode == OP_TYPE)
11237 {
11238 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11239 arg1 = NULL;
11240 type_arg = check_typedef (exp->elts[pc + 2].type);
11241 }
11242 else
11243 {
11244 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11245 type_arg = NULL;
11246 }
11247
11248 if (exp->elts[*pos].opcode != OP_LONG)
11249 error (_("Invalid operand to '%s"), ada_attribute_name (op));
11250 tem = longest_to_int (exp->elts[*pos + 2].longconst);
11251 *pos += 4;
11252
11253 if (noside == EVAL_SKIP)
11254 goto nosideret;
11255
11256 if (type_arg == NULL)
11257 {
11258 arg1 = ada_coerce_ref (arg1);
11259
11260 if (ada_is_constrained_packed_array_type (value_type (arg1)))
11261 arg1 = ada_coerce_to_simple_array (arg1);
11262
11263 if (op == OP_ATR_LENGTH)
11264 type = builtin_type (exp->gdbarch)->builtin_int;
11265 else
11266 {
11267 type = ada_index_type (value_type (arg1), tem,
11268 ada_attribute_name (op));
11269 if (type == NULL)
11270 type = builtin_type (exp->gdbarch)->builtin_int;
11271 }
11272
11273 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11274 return allocate_value (type);
11275
11276 switch (op)
11277 {
11278 default: /* Should never happen. */
11279 error (_("unexpected attribute encountered"));
11280 case OP_ATR_FIRST:
11281 return value_from_longest
11282 (type, ada_array_bound (arg1, tem, 0));
11283 case OP_ATR_LAST:
11284 return value_from_longest
11285 (type, ada_array_bound (arg1, tem, 1));
11286 case OP_ATR_LENGTH:
11287 return value_from_longest
11288 (type, ada_array_length (arg1, tem));
11289 }
11290 }
11291 else if (discrete_type_p (type_arg))
11292 {
11293 struct type *range_type;
11294 const char *name = ada_type_name (type_arg);
11295
11296 range_type = NULL;
11297 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
11298 range_type = to_fixed_range_type (type_arg, NULL);
11299 if (range_type == NULL)
11300 range_type = type_arg;
11301 switch (op)
11302 {
11303 default:
11304 error (_("unexpected attribute encountered"));
11305 case OP_ATR_FIRST:
11306 return value_from_longest
11307 (range_type, ada_discrete_type_low_bound (range_type));
11308 case OP_ATR_LAST:
11309 return value_from_longest
11310 (range_type, ada_discrete_type_high_bound (range_type));
11311 case OP_ATR_LENGTH:
11312 error (_("the 'length attribute applies only to array types"));
11313 }
11314 }
11315 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
11316 error (_("unimplemented type attribute"));
11317 else
11318 {
11319 LONGEST low, high;
11320
11321 if (ada_is_constrained_packed_array_type (type_arg))
11322 type_arg = decode_constrained_packed_array_type (type_arg);
11323
11324 if (op == OP_ATR_LENGTH)
11325 type = builtin_type (exp->gdbarch)->builtin_int;
11326 else
11327 {
11328 type = ada_index_type (type_arg, tem, ada_attribute_name (op));
11329 if (type == NULL)
11330 type = builtin_type (exp->gdbarch)->builtin_int;
11331 }
11332
11333 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11334 return allocate_value (type);
11335
11336 switch (op)
11337 {
11338 default:
11339 error (_("unexpected attribute encountered"));
11340 case OP_ATR_FIRST:
11341 low = ada_array_bound_from_type (type_arg, tem, 0);
11342 return value_from_longest (type, low);
11343 case OP_ATR_LAST:
11344 high = ada_array_bound_from_type (type_arg, tem, 1);
11345 return value_from_longest (type, high);
11346 case OP_ATR_LENGTH:
11347 low = ada_array_bound_from_type (type_arg, tem, 0);
11348 high = ada_array_bound_from_type (type_arg, tem, 1);
11349 return value_from_longest (type, high - low + 1);
11350 }
11351 }
11352 }
11353
11354 case OP_ATR_TAG:
11355 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11356 if (noside == EVAL_SKIP)
11357 goto nosideret;
11358
11359 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11360 return value_zero (ada_tag_type (arg1), not_lval);
11361
11362 return ada_value_tag (arg1);
11363
11364 case OP_ATR_MIN:
11365 case OP_ATR_MAX:
11366 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11367 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11368 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11369 if (noside == EVAL_SKIP)
11370 goto nosideret;
11371 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11372 return value_zero (value_type (arg1), not_lval);
11373 else
11374 {
11375 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11376 return value_binop (arg1, arg2,
11377 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
11378 }
11379
11380 case OP_ATR_MODULUS:
11381 {
11382 struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
11383
11384 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11385 if (noside == EVAL_SKIP)
11386 goto nosideret;
11387
11388 if (!ada_is_modular_type (type_arg))
11389 error (_("'modulus must be applied to modular type"));
11390
11391 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
11392 ada_modulus (type_arg));
11393 }
11394
11395
11396 case OP_ATR_POS:
11397 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11398 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11399 if (noside == EVAL_SKIP)
11400 goto nosideret;
11401 type = builtin_type (exp->gdbarch)->builtin_int;
11402 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11403 return value_zero (type, not_lval);
11404 else
11405 return value_pos_atr (type, arg1);
11406
11407 case OP_ATR_SIZE:
11408 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11409 type = value_type (arg1);
11410
11411 /* If the argument is a reference, then dereference its type, since
11412 the user is really asking for the size of the actual object,
11413 not the size of the pointer. */
11414 if (TYPE_CODE (type) == TYPE_CODE_REF)
11415 type = TYPE_TARGET_TYPE (type);
11416
11417 if (noside == EVAL_SKIP)
11418 goto nosideret;
11419 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11420 return value_zero (builtin_type (exp->gdbarch)->builtin_int, not_lval);
11421 else
11422 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
11423 TARGET_CHAR_BIT * TYPE_LENGTH (type));
11424
11425 case OP_ATR_VAL:
11426 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
11427 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11428 type = exp->elts[pc + 2].type;
11429 if (noside == EVAL_SKIP)
11430 goto nosideret;
11431 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11432 return value_zero (type, not_lval);
11433 else
11434 return value_val_atr (type, arg1);
11435
11436 case BINOP_EXP:
11437 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11438 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11439 if (noside == EVAL_SKIP)
11440 goto nosideret;
11441 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11442 return value_zero (value_type (arg1), not_lval);
11443 else
11444 {
11445 /* For integer exponentiation operations,
11446 only promote the first argument. */
11447 if (is_integral_type (value_type (arg2)))
11448 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11449 else
11450 binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11451
11452 return value_binop (arg1, arg2, op);
11453 }
11454
11455 case UNOP_PLUS:
11456 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11457 if (noside == EVAL_SKIP)
11458 goto nosideret;
11459 else
11460 return arg1;
11461
11462 case UNOP_ABS:
11463 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11464 if (noside == EVAL_SKIP)
11465 goto nosideret;
11466 unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11467 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
11468 return value_neg (arg1);
11469 else
11470 return arg1;
11471
11472 case UNOP_IND:
11473 preeval_pos = *pos;
11474 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11475 if (noside == EVAL_SKIP)
11476 goto nosideret;
11477 type = ada_check_typedef (value_type (arg1));
11478 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11479 {
11480 if (ada_is_array_descriptor_type (type))
11481 /* GDB allows dereferencing GNAT array descriptors. */
11482 {
11483 struct type *arrType = ada_type_of_array (arg1, 0);
11484
11485 if (arrType == NULL)
11486 error (_("Attempt to dereference null array pointer."));
11487 return value_at_lazy (arrType, 0);
11488 }
11489 else if (TYPE_CODE (type) == TYPE_CODE_PTR
11490 || TYPE_CODE (type) == TYPE_CODE_REF
11491 /* In C you can dereference an array to get the 1st elt. */
11492 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
11493 {
11494 /* As mentioned in the OP_VAR_VALUE case, tagged types can
11495 only be determined by inspecting the object's tag.
11496 This means that we need to evaluate completely the
11497 expression in order to get its type. */
11498
11499 if ((TYPE_CODE (type) == TYPE_CODE_REF
11500 || TYPE_CODE (type) == TYPE_CODE_PTR)
11501 && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11502 {
11503 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11504 EVAL_NORMAL);
11505 type = value_type (ada_value_ind (arg1));
11506 }
11507 else
11508 {
11509 type = to_static_fixed_type
11510 (ada_aligned_type
11511 (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11512 }
11513 ada_ensure_varsize_limit (type);
11514 return value_zero (type, lval_memory);
11515 }
11516 else if (TYPE_CODE (type) == TYPE_CODE_INT)
11517 {
11518 /* GDB allows dereferencing an int. */
11519 if (expect_type == NULL)
11520 return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11521 lval_memory);
11522 else
11523 {
11524 expect_type =
11525 to_static_fixed_type (ada_aligned_type (expect_type));
11526 return value_zero (expect_type, lval_memory);
11527 }
11528 }
11529 else
11530 error (_("Attempt to take contents of a non-pointer value."));
11531 }
11532 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11533 type = ada_check_typedef (value_type (arg1));
11534
11535 if (TYPE_CODE (type) == TYPE_CODE_INT)
11536 /* GDB allows dereferencing an int. If we were given
11537 the expect_type, then use that as the target type.
11538 Otherwise, assume that the target type is an int. */
11539 {
11540 if (expect_type != NULL)
11541 return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11542 arg1));
11543 else
11544 return value_at_lazy (builtin_type (exp->gdbarch)->builtin_int,
11545 (CORE_ADDR) value_as_address (arg1));
11546 }
11547
11548 if (ada_is_array_descriptor_type (type))
11549 /* GDB allows dereferencing GNAT array descriptors. */
11550 return ada_coerce_to_simple_array (arg1);
11551 else
11552 return ada_value_ind (arg1);
11553
11554 case STRUCTOP_STRUCT:
11555 tem = longest_to_int (exp->elts[pc + 1].longconst);
11556 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
11557 preeval_pos = *pos;
11558 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11559 if (noside == EVAL_SKIP)
11560 goto nosideret;
11561 if (noside == EVAL_AVOID_SIDE_EFFECTS)
11562 {
11563 struct type *type1 = value_type (arg1);
11564
11565 if (ada_is_tagged_type (type1, 1))
11566 {
11567 type = ada_lookup_struct_elt_type (type1,
11568 &exp->elts[pc + 2].string,
11569 1, 1);
11570
11571 /* If the field is not found, check if it exists in the
11572 extension of this object's type. This means that we
11573 need to evaluate completely the expression. */
11574
11575 if (type == NULL)
11576 {
11577 arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11578 EVAL_NORMAL);
11579 arg1 = ada_value_struct_elt (arg1,
11580 &exp->elts[pc + 2].string,
11581 0);
11582 arg1 = unwrap_value (arg1);
11583 type = value_type (ada_to_fixed_value (arg1));
11584 }
11585 }
11586 else
11587 type =
11588 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11589 0);
11590
11591 return value_zero (ada_aligned_type (type), lval_memory);
11592 }
11593 else
11594 {
11595 arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11596 arg1 = unwrap_value (arg1);
11597 return ada_to_fixed_value (arg1);
11598 }
11599
11600 case OP_TYPE:
11601 /* The value is not supposed to be used. This is here to make it
11602 easier to accommodate expressions that contain types. */
11603 (*pos) += 2;
11604 if (noside == EVAL_SKIP)
11605 goto nosideret;
11606 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11607 return allocate_value (exp->elts[pc + 1].type);
11608 else
11609 error (_("Attempt to use a type name as an expression"));
11610
11611 case OP_AGGREGATE:
11612 case OP_CHOICES:
11613 case OP_OTHERS:
11614 case OP_DISCRETE_RANGE:
11615 case OP_POSITIONAL:
11616 case OP_NAME:
11617 if (noside == EVAL_NORMAL)
11618 switch (op)
11619 {
11620 case OP_NAME:
11621 error (_("Undefined name, ambiguous name, or renaming used in "
11622 "component association: %s."), &exp->elts[pc+2].string);
11623 case OP_AGGREGATE:
11624 error (_("Aggregates only allowed on the right of an assignment"));
11625 default:
11626 internal_error (__FILE__, __LINE__,
11627 _("aggregate apparently mangled"));
11628 }
11629
11630 ada_forward_operator_length (exp, pc, &oplen, &nargs);
11631 *pos += oplen - 1;
11632 for (tem = 0; tem < nargs; tem += 1)
11633 ada_evaluate_subexp (NULL, exp, pos, noside);
11634 goto nosideret;
11635 }
11636
11637 nosideret:
11638 return eval_skip_value (exp);
11639 }
11640
11641
11642 /* Fixed point */
11643
11644 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11645 type name that encodes the 'small and 'delta information.
11646 Otherwise, return NULL. */
11647
11648 static const char *
11649 fixed_type_info (struct type *type)
11650 {
11651 const char *name = ada_type_name (type);
11652 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11653
11654 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11655 {
11656 const char *tail = strstr (name, "___XF_");
11657
11658 if (tail == NULL)
11659 return NULL;
11660 else
11661 return tail + 5;
11662 }
11663 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11664 return fixed_type_info (TYPE_TARGET_TYPE (type));
11665 else
11666 return NULL;
11667 }
11668
11669 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11670
11671 int
11672 ada_is_fixed_point_type (struct type *type)
11673 {
11674 return fixed_type_info (type) != NULL;
11675 }
11676
11677 /* Return non-zero iff TYPE represents a System.Address type. */
11678
11679 int
11680 ada_is_system_address_type (struct type *type)
11681 {
11682 return (TYPE_NAME (type)
11683 && strcmp (TYPE_NAME (type), "system__address") == 0);
11684 }
11685
11686 /* Assuming that TYPE is the representation of an Ada fixed-point
11687 type, return the target floating-point type to be used to represent
11688 of this type during internal computation. */
11689
11690 static struct type *
11691 ada_scaling_type (struct type *type)
11692 {
11693 return builtin_type (get_type_arch (type))->builtin_long_double;
11694 }
11695
11696 /* Assuming that TYPE is the representation of an Ada fixed-point
11697 type, return its delta, or NULL if the type is malformed and the
11698 delta cannot be determined. */
11699
11700 struct value *
11701 ada_delta (struct type *type)
11702 {
11703 const char *encoding = fixed_type_info (type);
11704 struct type *scale_type = ada_scaling_type (type);
11705
11706 long long num, den;
11707
11708 if (sscanf (encoding, "_%lld_%lld", &num, &den) < 2)
11709 return nullptr;
11710 else
11711 return value_binop (value_from_longest (scale_type, num),
11712 value_from_longest (scale_type, den), BINOP_DIV);
11713 }
11714
11715 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11716 factor ('SMALL value) associated with the type. */
11717
11718 struct value *
11719 ada_scaling_factor (struct type *type)
11720 {
11721 const char *encoding = fixed_type_info (type);
11722 struct type *scale_type = ada_scaling_type (type);
11723
11724 long long num0, den0, num1, den1;
11725 int n;
11726
11727 n = sscanf (encoding, "_%lld_%lld_%lld_%lld",
11728 &num0, &den0, &num1, &den1);
11729
11730 if (n < 2)
11731 return value_from_longest (scale_type, 1);
11732 else if (n == 4)
11733 return value_binop (value_from_longest (scale_type, num1),
11734 value_from_longest (scale_type, den1), BINOP_DIV);
11735 else
11736 return value_binop (value_from_longest (scale_type, num0),
11737 value_from_longest (scale_type, den0), BINOP_DIV);
11738 }
11739
11740
11741
11742 /* Range types */
11743
11744 /* Scan STR beginning at position K for a discriminant name, and
11745 return the value of that discriminant field of DVAL in *PX. If
11746 PNEW_K is not null, put the position of the character beyond the
11747 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11748 not alter *PX and *PNEW_K if unsuccessful. */
11749
11750 static int
11751 scan_discrim_bound (const char *str, int k, struct value *dval, LONGEST * px,
11752 int *pnew_k)
11753 {
11754 static char *bound_buffer = NULL;
11755 static size_t bound_buffer_len = 0;
11756 const char *pstart, *pend, *bound;
11757 struct value *bound_val;
11758
11759 if (dval == NULL || str == NULL || str[k] == '\0')
11760 return 0;
11761
11762 pstart = str + k;
11763 pend = strstr (pstart, "__");
11764 if (pend == NULL)
11765 {
11766 bound = pstart;
11767 k += strlen (bound);
11768 }
11769 else
11770 {
11771 int len = pend - pstart;
11772
11773 /* Strip __ and beyond. */
11774 GROW_VECT (bound_buffer, bound_buffer_len, len + 1);
11775 strncpy (bound_buffer, pstart, len);
11776 bound_buffer[len] = '\0';
11777
11778 bound = bound_buffer;
11779 k = pend - str;
11780 }
11781
11782 bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11783 if (bound_val == NULL)
11784 return 0;
11785
11786 *px = value_as_long (bound_val);
11787 if (pnew_k != NULL)
11788 *pnew_k = k;
11789 return 1;
11790 }
11791
11792 /* Value of variable named NAME in the current environment. If
11793 no such variable found, then if ERR_MSG is null, returns 0, and
11794 otherwise causes an error with message ERR_MSG. */
11795
11796 static struct value *
11797 get_var_value (const char *name, const char *err_msg)
11798 {
11799 lookup_name_info lookup_name (name, symbol_name_match_type::FULL);
11800
11801 struct block_symbol *syms;
11802 int nsyms = ada_lookup_symbol_list_worker (lookup_name,
11803 get_selected_block (0),
11804 VAR_DOMAIN, &syms, 1);
11805 struct cleanup *old_chain = make_cleanup (xfree, syms);
11806
11807 if (nsyms != 1)
11808 {
11809 do_cleanups (old_chain);
11810 if (err_msg == NULL)
11811 return 0;
11812 else
11813 error (("%s"), err_msg);
11814 }
11815
11816 struct value *result = value_of_variable (syms[0].symbol, syms[0].block);
11817 do_cleanups (old_chain);
11818 return result;
11819 }
11820
11821 /* Value of integer variable named NAME in the current environment.
11822 If no such variable is found, returns false. Otherwise, sets VALUE
11823 to the variable's value and returns true. */
11824
11825 bool
11826 get_int_var_value (const char *name, LONGEST &value)
11827 {
11828 struct value *var_val = get_var_value (name, 0);
11829
11830 if (var_val == 0)
11831 return false;
11832
11833 value = value_as_long (var_val);
11834 return true;
11835 }
11836
11837
11838 /* Return a range type whose base type is that of the range type named
11839 NAME in the current environment, and whose bounds are calculated
11840 from NAME according to the GNAT range encoding conventions.
11841 Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11842 corresponding range type from debug information; fall back to using it
11843 if symbol lookup fails. If a new type must be created, allocate it
11844 like ORIG_TYPE was. The bounds information, in general, is encoded
11845 in NAME, the base type given in the named range type. */
11846
11847 static struct type *
11848 to_fixed_range_type (struct type *raw_type, struct value *dval)
11849 {
11850 const char *name;
11851 struct type *base_type;
11852 const char *subtype_info;
11853
11854 gdb_assert (raw_type != NULL);
11855 gdb_assert (TYPE_NAME (raw_type) != NULL);
11856
11857 if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
11858 base_type = TYPE_TARGET_TYPE (raw_type);
11859 else
11860 base_type = raw_type;
11861
11862 name = TYPE_NAME (raw_type);
11863 subtype_info = strstr (name, "___XD");
11864 if (subtype_info == NULL)
11865 {
11866 LONGEST L = ada_discrete_type_low_bound (raw_type);
11867 LONGEST U = ada_discrete_type_high_bound (raw_type);
11868
11869 if (L < INT_MIN || U > INT_MAX)
11870 return raw_type;
11871 else
11872 return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11873 L, U);
11874 }
11875 else
11876 {
11877 static char *name_buf = NULL;
11878 static size_t name_len = 0;
11879 int prefix_len = subtype_info - name;
11880 LONGEST L, U;
11881 struct type *type;
11882 const char *bounds_str;
11883 int n;
11884
11885 GROW_VECT (name_buf, name_len, prefix_len + 5);
11886 strncpy (name_buf, name, prefix_len);
11887 name_buf[prefix_len] = '\0';
11888
11889 subtype_info += 5;
11890 bounds_str = strchr (subtype_info, '_');
11891 n = 1;
11892
11893 if (*subtype_info == 'L')
11894 {
11895 if (!ada_scan_number (bounds_str, n, &L, &n)
11896 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11897 return raw_type;
11898 if (bounds_str[n] == '_')
11899 n += 2;
11900 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11901 n += 1;
11902 subtype_info += 1;
11903 }
11904 else
11905 {
11906 strcpy (name_buf + prefix_len, "___L");
11907 if (!get_int_var_value (name_buf, L))
11908 {
11909 lim_warning (_("Unknown lower bound, using 1."));
11910 L = 1;
11911 }
11912 }
11913
11914 if (*subtype_info == 'U')
11915 {
11916 if (!ada_scan_number (bounds_str, n, &U, &n)
11917 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11918 return raw_type;
11919 }
11920 else
11921 {
11922 strcpy (name_buf + prefix_len, "___U");
11923 if (!get_int_var_value (name_buf, U))
11924 {
11925 lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11926 U = L;
11927 }
11928 }
11929
11930 type = create_static_range_type (alloc_type_copy (raw_type),
11931 base_type, L, U);
11932 /* create_static_range_type alters the resulting type's length
11933 to match the size of the base_type, which is not what we want.
11934 Set it back to the original range type's length. */
11935 TYPE_LENGTH (type) = TYPE_LENGTH (raw_type);
11936 TYPE_NAME (type) = name;
11937 return type;
11938 }
11939 }
11940
11941 /* True iff NAME is the name of a range type. */
11942
11943 int
11944 ada_is_range_type_name (const char *name)
11945 {
11946 return (name != NULL && strstr (name, "___XD"));
11947 }
11948
11949
11950 /* Modular types */
11951
11952 /* True iff TYPE is an Ada modular type. */
11953
11954 int
11955 ada_is_modular_type (struct type *type)
11956 {
11957 struct type *subranged_type = get_base_type (type);
11958
11959 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
11960 && TYPE_CODE (subranged_type) == TYPE_CODE_INT
11961 && TYPE_UNSIGNED (subranged_type));
11962 }
11963
11964 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11965
11966 ULONGEST
11967 ada_modulus (struct type *type)
11968 {
11969 return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
11970 }
11971
11972
11973 /* Ada exception catchpoint support:
11974 ---------------------------------
11975
11976 We support 3 kinds of exception catchpoints:
11977 . catchpoints on Ada exceptions
11978 . catchpoints on unhandled Ada exceptions
11979 . catchpoints on failed assertions
11980
11981 Exceptions raised during failed assertions, or unhandled exceptions
11982 could perfectly be caught with the general catchpoint on Ada exceptions.
11983 However, we can easily differentiate these two special cases, and having
11984 the option to distinguish these two cases from the rest can be useful
11985 to zero-in on certain situations.
11986
11987 Exception catchpoints are a specialized form of breakpoint,
11988 since they rely on inserting breakpoints inside known routines
11989 of the GNAT runtime. The implementation therefore uses a standard
11990 breakpoint structure of the BP_BREAKPOINT type, but with its own set
11991 of breakpoint_ops.
11992
11993 Support in the runtime for exception catchpoints have been changed
11994 a few times already, and these changes affect the implementation
11995 of these catchpoints. In order to be able to support several
11996 variants of the runtime, we use a sniffer that will determine
11997 the runtime variant used by the program being debugged. */
11998
11999 /* Ada's standard exceptions.
12000
12001 The Ada 83 standard also defined Numeric_Error. But there so many
12002 situations where it was unclear from the Ada 83 Reference Manual
12003 (RM) whether Constraint_Error or Numeric_Error should be raised,
12004 that the ARG (Ada Rapporteur Group) eventually issued a Binding
12005 Interpretation saying that anytime the RM says that Numeric_Error
12006 should be raised, the implementation may raise Constraint_Error.
12007 Ada 95 went one step further and pretty much removed Numeric_Error
12008 from the list of standard exceptions (it made it a renaming of
12009 Constraint_Error, to help preserve compatibility when compiling
12010 an Ada83 compiler). As such, we do not include Numeric_Error from
12011 this list of standard exceptions. */
12012
12013 static const char *standard_exc[] = {
12014 "constraint_error",
12015 "program_error",
12016 "storage_error",
12017 "tasking_error"
12018 };
12019
12020 typedef CORE_ADDR (ada_unhandled_exception_name_addr_ftype) (void);
12021
12022 /* A structure that describes how to support exception catchpoints
12023 for a given executable. */
12024
12025 struct exception_support_info
12026 {
12027 /* The name of the symbol to break on in order to insert
12028 a catchpoint on exceptions. */
12029 const char *catch_exception_sym;
12030
12031 /* The name of the symbol to break on in order to insert
12032 a catchpoint on unhandled exceptions. */
12033 const char *catch_exception_unhandled_sym;
12034
12035 /* The name of the symbol to break on in order to insert
12036 a catchpoint on failed assertions. */
12037 const char *catch_assert_sym;
12038
12039 /* The name of the symbol to break on in order to insert
12040 a catchpoint on exception handling. */
12041 const char *catch_handlers_sym;
12042
12043 /* Assuming that the inferior just triggered an unhandled exception
12044 catchpoint, this function is responsible for returning the address
12045 in inferior memory where the name of that exception is stored.
12046 Return zero if the address could not be computed. */
12047 ada_unhandled_exception_name_addr_ftype *unhandled_exception_name_addr;
12048 };
12049
12050 static CORE_ADDR ada_unhandled_exception_name_addr (void);
12051 static CORE_ADDR ada_unhandled_exception_name_addr_from_raise (void);
12052
12053 /* The following exception support info structure describes how to
12054 implement exception catchpoints with the latest version of the
12055 Ada runtime (as of 2007-03-06). */
12056
12057 static const struct exception_support_info default_exception_support_info =
12058 {
12059 "__gnat_debug_raise_exception", /* catch_exception_sym */
12060 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12061 "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
12062 "__gnat_begin_handler", /* catch_handlers_sym */
12063 ada_unhandled_exception_name_addr
12064 };
12065
12066 /* The following exception support info structure describes how to
12067 implement exception catchpoints with a slightly older version
12068 of the Ada runtime. */
12069
12070 static const struct exception_support_info exception_support_info_fallback =
12071 {
12072 "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
12073 "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
12074 "system__assertions__raise_assert_failure", /* catch_assert_sym */
12075 "__gnat_begin_handler", /* catch_handlers_sym */
12076 ada_unhandled_exception_name_addr_from_raise
12077 };
12078
12079 /* Return nonzero if we can detect the exception support routines
12080 described in EINFO.
12081
12082 This function errors out if an abnormal situation is detected
12083 (for instance, if we find the exception support routines, but
12084 that support is found to be incomplete). */
12085
12086 static int
12087 ada_has_this_exception_support (const struct exception_support_info *einfo)
12088 {
12089 struct symbol *sym;
12090
12091 /* The symbol we're looking up is provided by a unit in the GNAT runtime
12092 that should be compiled with debugging information. As a result, we
12093 expect to find that symbol in the symtabs. */
12094
12095 sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
12096 if (sym == NULL)
12097 {
12098 /* Perhaps we did not find our symbol because the Ada runtime was
12099 compiled without debugging info, or simply stripped of it.
12100 It happens on some GNU/Linux distributions for instance, where
12101 users have to install a separate debug package in order to get
12102 the runtime's debugging info. In that situation, let the user
12103 know why we cannot insert an Ada exception catchpoint.
12104
12105 Note: Just for the purpose of inserting our Ada exception
12106 catchpoint, we could rely purely on the associated minimal symbol.
12107 But we would be operating in degraded mode anyway, since we are
12108 still lacking the debugging info needed later on to extract
12109 the name of the exception being raised (this name is printed in
12110 the catchpoint message, and is also used when trying to catch
12111 a specific exception). We do not handle this case for now. */
12112 struct bound_minimal_symbol msym
12113 = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
12114
12115 if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
12116 error (_("Your Ada runtime appears to be missing some debugging "
12117 "information.\nCannot insert Ada exception catchpoint "
12118 "in this configuration."));
12119
12120 return 0;
12121 }
12122
12123 /* Make sure that the symbol we found corresponds to a function. */
12124
12125 if (SYMBOL_CLASS (sym) != LOC_BLOCK)
12126 error (_("Symbol \"%s\" is not a function (class = %d)"),
12127 SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
12128
12129 return 1;
12130 }
12131
12132 /* Inspect the Ada runtime and determine which exception info structure
12133 should be used to provide support for exception catchpoints.
12134
12135 This function will always set the per-inferior exception_info,
12136 or raise an error. */
12137
12138 static void
12139 ada_exception_support_info_sniffer (void)
12140 {
12141 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12142
12143 /* If the exception info is already known, then no need to recompute it. */
12144 if (data->exception_info != NULL)
12145 return;
12146
12147 /* Check the latest (default) exception support info. */
12148 if (ada_has_this_exception_support (&default_exception_support_info))
12149 {
12150 data->exception_info = &default_exception_support_info;
12151 return;
12152 }
12153
12154 /* Try our fallback exception suport info. */
12155 if (ada_has_this_exception_support (&exception_support_info_fallback))
12156 {
12157 data->exception_info = &exception_support_info_fallback;
12158 return;
12159 }
12160
12161 /* Sometimes, it is normal for us to not be able to find the routine
12162 we are looking for. This happens when the program is linked with
12163 the shared version of the GNAT runtime, and the program has not been
12164 started yet. Inform the user of these two possible causes if
12165 applicable. */
12166
12167 if (ada_update_initial_language (language_unknown) != language_ada)
12168 error (_("Unable to insert catchpoint. Is this an Ada main program?"));
12169
12170 /* If the symbol does not exist, then check that the program is
12171 already started, to make sure that shared libraries have been
12172 loaded. If it is not started, this may mean that the symbol is
12173 in a shared library. */
12174
12175 if (ptid_get_pid (inferior_ptid) == 0)
12176 error (_("Unable to insert catchpoint. Try to start the program first."));
12177
12178 /* At this point, we know that we are debugging an Ada program and
12179 that the inferior has been started, but we still are not able to
12180 find the run-time symbols. That can mean that we are in
12181 configurable run time mode, or that a-except as been optimized
12182 out by the linker... In any case, at this point it is not worth
12183 supporting this feature. */
12184
12185 error (_("Cannot insert Ada exception catchpoints in this configuration."));
12186 }
12187
12188 /* True iff FRAME is very likely to be that of a function that is
12189 part of the runtime system. This is all very heuristic, but is
12190 intended to be used as advice as to what frames are uninteresting
12191 to most users. */
12192
12193 static int
12194 is_known_support_routine (struct frame_info *frame)
12195 {
12196 enum language func_lang;
12197 int i;
12198 const char *fullname;
12199
12200 /* If this code does not have any debugging information (no symtab),
12201 This cannot be any user code. */
12202
12203 symtab_and_line sal = find_frame_sal (frame);
12204 if (sal.symtab == NULL)
12205 return 1;
12206
12207 /* If there is a symtab, but the associated source file cannot be
12208 located, then assume this is not user code: Selecting a frame
12209 for which we cannot display the code would not be very helpful
12210 for the user. This should also take care of case such as VxWorks
12211 where the kernel has some debugging info provided for a few units. */
12212
12213 fullname = symtab_to_fullname (sal.symtab);
12214 if (access (fullname, R_OK) != 0)
12215 return 1;
12216
12217 /* Check the unit filename againt the Ada runtime file naming.
12218 We also check the name of the objfile against the name of some
12219 known system libraries that sometimes come with debugging info
12220 too. */
12221
12222 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
12223 {
12224 re_comp (known_runtime_file_name_patterns[i]);
12225 if (re_exec (lbasename (sal.symtab->filename)))
12226 return 1;
12227 if (SYMTAB_OBJFILE (sal.symtab) != NULL
12228 && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
12229 return 1;
12230 }
12231
12232 /* Check whether the function is a GNAT-generated entity. */
12233
12234 gdb::unique_xmalloc_ptr<char> func_name
12235 = find_frame_funname (frame, &func_lang, NULL);
12236 if (func_name == NULL)
12237 return 1;
12238
12239 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
12240 {
12241 re_comp (known_auxiliary_function_name_patterns[i]);
12242 if (re_exec (func_name.get ()))
12243 return 1;
12244 }
12245
12246 return 0;
12247 }
12248
12249 /* Find the first frame that contains debugging information and that is not
12250 part of the Ada run-time, starting from FI and moving upward. */
12251
12252 void
12253 ada_find_printable_frame (struct frame_info *fi)
12254 {
12255 for (; fi != NULL; fi = get_prev_frame (fi))
12256 {
12257 if (!is_known_support_routine (fi))
12258 {
12259 select_frame (fi);
12260 break;
12261 }
12262 }
12263
12264 }
12265
12266 /* Assuming that the inferior just triggered an unhandled exception
12267 catchpoint, return the address in inferior memory where the name
12268 of the exception is stored.
12269
12270 Return zero if the address could not be computed. */
12271
12272 static CORE_ADDR
12273 ada_unhandled_exception_name_addr (void)
12274 {
12275 return parse_and_eval_address ("e.full_name");
12276 }
12277
12278 /* Same as ada_unhandled_exception_name_addr, except that this function
12279 should be used when the inferior uses an older version of the runtime,
12280 where the exception name needs to be extracted from a specific frame
12281 several frames up in the callstack. */
12282
12283 static CORE_ADDR
12284 ada_unhandled_exception_name_addr_from_raise (void)
12285 {
12286 int frame_level;
12287 struct frame_info *fi;
12288 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12289
12290 /* To determine the name of this exception, we need to select
12291 the frame corresponding to RAISE_SYM_NAME. This frame is
12292 at least 3 levels up, so we simply skip the first 3 frames
12293 without checking the name of their associated function. */
12294 fi = get_current_frame ();
12295 for (frame_level = 0; frame_level < 3; frame_level += 1)
12296 if (fi != NULL)
12297 fi = get_prev_frame (fi);
12298
12299 while (fi != NULL)
12300 {
12301 enum language func_lang;
12302
12303 gdb::unique_xmalloc_ptr<char> func_name
12304 = find_frame_funname (fi, &func_lang, NULL);
12305 if (func_name != NULL)
12306 {
12307 if (strcmp (func_name.get (),
12308 data->exception_info->catch_exception_sym) == 0)
12309 break; /* We found the frame we were looking for... */
12310 fi = get_prev_frame (fi);
12311 }
12312 }
12313
12314 if (fi == NULL)
12315 return 0;
12316
12317 select_frame (fi);
12318 return parse_and_eval_address ("id.full_name");
12319 }
12320
12321 /* Assuming the inferior just triggered an Ada exception catchpoint
12322 (of any type), return the address in inferior memory where the name
12323 of the exception is stored, if applicable.
12324
12325 Assumes the selected frame is the current frame.
12326
12327 Return zero if the address could not be computed, or if not relevant. */
12328
12329 static CORE_ADDR
12330 ada_exception_name_addr_1 (enum ada_exception_catchpoint_kind ex,
12331 struct breakpoint *b)
12332 {
12333 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12334
12335 switch (ex)
12336 {
12337 case ada_catch_exception:
12338 return (parse_and_eval_address ("e.full_name"));
12339 break;
12340
12341 case ada_catch_exception_unhandled:
12342 return data->exception_info->unhandled_exception_name_addr ();
12343 break;
12344
12345 case ada_catch_handlers:
12346 return 0; /* The runtimes does not provide access to the exception
12347 name. */
12348 break;
12349
12350 case ada_catch_assert:
12351 return 0; /* Exception name is not relevant in this case. */
12352 break;
12353
12354 default:
12355 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12356 break;
12357 }
12358
12359 return 0; /* Should never be reached. */
12360 }
12361
12362 /* Assuming the inferior is stopped at an exception catchpoint,
12363 return the message which was associated to the exception, if
12364 available. Return NULL if the message could not be retrieved.
12365
12366 The caller must xfree the string after use.
12367
12368 Note: The exception message can be associated to an exception
12369 either through the use of the Raise_Exception function, or
12370 more simply (Ada 2005 and later), via:
12371
12372 raise Exception_Name with "exception message";
12373
12374 */
12375
12376 static char *
12377 ada_exception_message_1 (void)
12378 {
12379 struct value *e_msg_val;
12380 char *e_msg = NULL;
12381 int e_msg_len;
12382 struct cleanup *cleanups;
12383
12384 /* For runtimes that support this feature, the exception message
12385 is passed as an unbounded string argument called "message". */
12386 e_msg_val = parse_and_eval ("message");
12387 if (e_msg_val == NULL)
12388 return NULL; /* Exception message not supported. */
12389
12390 e_msg_val = ada_coerce_to_simple_array (e_msg_val);
12391 gdb_assert (e_msg_val != NULL);
12392 e_msg_len = TYPE_LENGTH (value_type (e_msg_val));
12393
12394 /* If the message string is empty, then treat it as if there was
12395 no exception message. */
12396 if (e_msg_len <= 0)
12397 return NULL;
12398
12399 e_msg = (char *) xmalloc (e_msg_len + 1);
12400 cleanups = make_cleanup (xfree, e_msg);
12401 read_memory_string (value_address (e_msg_val), e_msg, e_msg_len + 1);
12402 e_msg[e_msg_len] = '\0';
12403
12404 discard_cleanups (cleanups);
12405 return e_msg;
12406 }
12407
12408 /* Same as ada_exception_message_1, except that all exceptions are
12409 contained here (returning NULL instead). */
12410
12411 static char *
12412 ada_exception_message (void)
12413 {
12414 char *e_msg = NULL; /* Avoid a spurious uninitialized warning. */
12415
12416 TRY
12417 {
12418 e_msg = ada_exception_message_1 ();
12419 }
12420 CATCH (e, RETURN_MASK_ERROR)
12421 {
12422 e_msg = NULL;
12423 }
12424 END_CATCH
12425
12426 return e_msg;
12427 }
12428
12429 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
12430 any error that ada_exception_name_addr_1 might cause to be thrown.
12431 When an error is intercepted, a warning with the error message is printed,
12432 and zero is returned. */
12433
12434 static CORE_ADDR
12435 ada_exception_name_addr (enum ada_exception_catchpoint_kind ex,
12436 struct breakpoint *b)
12437 {
12438 CORE_ADDR result = 0;
12439
12440 TRY
12441 {
12442 result = ada_exception_name_addr_1 (ex, b);
12443 }
12444
12445 CATCH (e, RETURN_MASK_ERROR)
12446 {
12447 warning (_("failed to get exception name: %s"), e.message);
12448 return 0;
12449 }
12450 END_CATCH
12451
12452 return result;
12453 }
12454
12455 static char *ada_exception_catchpoint_cond_string
12456 (const char *excep_string,
12457 enum ada_exception_catchpoint_kind ex);
12458
12459 /* Ada catchpoints.
12460
12461 In the case of catchpoints on Ada exceptions, the catchpoint will
12462 stop the target on every exception the program throws. When a user
12463 specifies the name of a specific exception, we translate this
12464 request into a condition expression (in text form), and then parse
12465 it into an expression stored in each of the catchpoint's locations.
12466 We then use this condition to check whether the exception that was
12467 raised is the one the user is interested in. If not, then the
12468 target is resumed again. We store the name of the requested
12469 exception, in order to be able to re-set the condition expression
12470 when symbols change. */
12471
12472 /* An instance of this type is used to represent an Ada catchpoint
12473 breakpoint location. */
12474
12475 class ada_catchpoint_location : public bp_location
12476 {
12477 public:
12478 ada_catchpoint_location (const bp_location_ops *ops, breakpoint *owner)
12479 : bp_location (ops, owner)
12480 {}
12481
12482 /* The condition that checks whether the exception that was raised
12483 is the specific exception the user specified on catchpoint
12484 creation. */
12485 expression_up excep_cond_expr;
12486 };
12487
12488 /* Implement the DTOR method in the bp_location_ops structure for all
12489 Ada exception catchpoint kinds. */
12490
12491 static void
12492 ada_catchpoint_location_dtor (struct bp_location *bl)
12493 {
12494 struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12495
12496 al->excep_cond_expr.reset ();
12497 }
12498
12499 /* The vtable to be used in Ada catchpoint locations. */
12500
12501 static const struct bp_location_ops ada_catchpoint_location_ops =
12502 {
12503 ada_catchpoint_location_dtor
12504 };
12505
12506 /* An instance of this type is used to represent an Ada catchpoint. */
12507
12508 struct ada_catchpoint : public breakpoint
12509 {
12510 ~ada_catchpoint () override;
12511
12512 /* The name of the specific exception the user specified. */
12513 char *excep_string;
12514 };
12515
12516 /* Parse the exception condition string in the context of each of the
12517 catchpoint's locations, and store them for later evaluation. */
12518
12519 static void
12520 create_excep_cond_exprs (struct ada_catchpoint *c,
12521 enum ada_exception_catchpoint_kind ex)
12522 {
12523 struct cleanup *old_chain;
12524 struct bp_location *bl;
12525 char *cond_string;
12526
12527 /* Nothing to do if there's no specific exception to catch. */
12528 if (c->excep_string == NULL)
12529 return;
12530
12531 /* Same if there are no locations... */
12532 if (c->loc == NULL)
12533 return;
12534
12535 /* Compute the condition expression in text form, from the specific
12536 expection we want to catch. */
12537 cond_string = ada_exception_catchpoint_cond_string (c->excep_string, ex);
12538 old_chain = make_cleanup (xfree, cond_string);
12539
12540 /* Iterate over all the catchpoint's locations, and parse an
12541 expression for each. */
12542 for (bl = c->loc; bl != NULL; bl = bl->next)
12543 {
12544 struct ada_catchpoint_location *ada_loc
12545 = (struct ada_catchpoint_location *) bl;
12546 expression_up exp;
12547
12548 if (!bl->shlib_disabled)
12549 {
12550 const char *s;
12551
12552 s = cond_string;
12553 TRY
12554 {
12555 exp = parse_exp_1 (&s, bl->address,
12556 block_for_pc (bl->address),
12557 0);
12558 }
12559 CATCH (e, RETURN_MASK_ERROR)
12560 {
12561 warning (_("failed to reevaluate internal exception condition "
12562 "for catchpoint %d: %s"),
12563 c->number, e.message);
12564 }
12565 END_CATCH
12566 }
12567
12568 ada_loc->excep_cond_expr = std::move (exp);
12569 }
12570
12571 do_cleanups (old_chain);
12572 }
12573
12574 /* ada_catchpoint destructor. */
12575
12576 ada_catchpoint::~ada_catchpoint ()
12577 {
12578 xfree (this->excep_string);
12579 }
12580
12581 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12582 structure for all exception catchpoint kinds. */
12583
12584 static struct bp_location *
12585 allocate_location_exception (enum ada_exception_catchpoint_kind ex,
12586 struct breakpoint *self)
12587 {
12588 return new ada_catchpoint_location (&ada_catchpoint_location_ops, self);
12589 }
12590
12591 /* Implement the RE_SET method in the breakpoint_ops structure for all
12592 exception catchpoint kinds. */
12593
12594 static void
12595 re_set_exception (enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
12596 {
12597 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12598
12599 /* Call the base class's method. This updates the catchpoint's
12600 locations. */
12601 bkpt_breakpoint_ops.re_set (b);
12602
12603 /* Reparse the exception conditional expressions. One for each
12604 location. */
12605 create_excep_cond_exprs (c, ex);
12606 }
12607
12608 /* Returns true if we should stop for this breakpoint hit. If the
12609 user specified a specific exception, we only want to cause a stop
12610 if the program thrown that exception. */
12611
12612 static int
12613 should_stop_exception (const struct bp_location *bl)
12614 {
12615 struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12616 const struct ada_catchpoint_location *ada_loc
12617 = (const struct ada_catchpoint_location *) bl;
12618 int stop;
12619
12620 /* With no specific exception, should always stop. */
12621 if (c->excep_string == NULL)
12622 return 1;
12623
12624 if (ada_loc->excep_cond_expr == NULL)
12625 {
12626 /* We will have a NULL expression if back when we were creating
12627 the expressions, this location's had failed to parse. */
12628 return 1;
12629 }
12630
12631 stop = 1;
12632 TRY
12633 {
12634 struct value *mark;
12635
12636 mark = value_mark ();
12637 stop = value_true (evaluate_expression (ada_loc->excep_cond_expr.get ()));
12638 value_free_to_mark (mark);
12639 }
12640 CATCH (ex, RETURN_MASK_ALL)
12641 {
12642 exception_fprintf (gdb_stderr, ex,
12643 _("Error in testing exception condition:\n"));
12644 }
12645 END_CATCH
12646
12647 return stop;
12648 }
12649
12650 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12651 for all exception catchpoint kinds. */
12652
12653 static void
12654 check_status_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12655 {
12656 bs->stop = should_stop_exception (bs->bp_location_at);
12657 }
12658
12659 /* Implement the PRINT_IT method in the breakpoint_ops structure
12660 for all exception catchpoint kinds. */
12661
12662 static enum print_stop_action
12663 print_it_exception (enum ada_exception_catchpoint_kind ex, bpstat bs)
12664 {
12665 struct ui_out *uiout = current_uiout;
12666 struct breakpoint *b = bs->breakpoint_at;
12667 char *exception_message;
12668
12669 annotate_catchpoint (b->number);
12670
12671 if (uiout->is_mi_like_p ())
12672 {
12673 uiout->field_string ("reason",
12674 async_reason_lookup (EXEC_ASYNC_BREAKPOINT_HIT));
12675 uiout->field_string ("disp", bpdisp_text (b->disposition));
12676 }
12677
12678 uiout->text (b->disposition == disp_del
12679 ? "\nTemporary catchpoint " : "\nCatchpoint ");
12680 uiout->field_int ("bkptno", b->number);
12681 uiout->text (", ");
12682
12683 /* ada_exception_name_addr relies on the selected frame being the
12684 current frame. Need to do this here because this function may be
12685 called more than once when printing a stop, and below, we'll
12686 select the first frame past the Ada run-time (see
12687 ada_find_printable_frame). */
12688 select_frame (get_current_frame ());
12689
12690 switch (ex)
12691 {
12692 case ada_catch_exception:
12693 case ada_catch_exception_unhandled:
12694 case ada_catch_handlers:
12695 {
12696 const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12697 char exception_name[256];
12698
12699 if (addr != 0)
12700 {
12701 read_memory (addr, (gdb_byte *) exception_name,
12702 sizeof (exception_name) - 1);
12703 exception_name [sizeof (exception_name) - 1] = '\0';
12704 }
12705 else
12706 {
12707 /* For some reason, we were unable to read the exception
12708 name. This could happen if the Runtime was compiled
12709 without debugging info, for instance. In that case,
12710 just replace the exception name by the generic string
12711 "exception" - it will read as "an exception" in the
12712 notification we are about to print. */
12713 memcpy (exception_name, "exception", sizeof ("exception"));
12714 }
12715 /* In the case of unhandled exception breakpoints, we print
12716 the exception name as "unhandled EXCEPTION_NAME", to make
12717 it clearer to the user which kind of catchpoint just got
12718 hit. We used ui_out_text to make sure that this extra
12719 info does not pollute the exception name in the MI case. */
12720 if (ex == ada_catch_exception_unhandled)
12721 uiout->text ("unhandled ");
12722 uiout->field_string ("exception-name", exception_name);
12723 }
12724 break;
12725 case ada_catch_assert:
12726 /* In this case, the name of the exception is not really
12727 important. Just print "failed assertion" to make it clearer
12728 that his program just hit an assertion-failure catchpoint.
12729 We used ui_out_text because this info does not belong in
12730 the MI output. */
12731 uiout->text ("failed assertion");
12732 break;
12733 }
12734
12735 exception_message = ada_exception_message ();
12736 if (exception_message != NULL)
12737 {
12738 struct cleanup *cleanups = make_cleanup (xfree, exception_message);
12739
12740 uiout->text (" (");
12741 uiout->field_string ("exception-message", exception_message);
12742 uiout->text (")");
12743
12744 do_cleanups (cleanups);
12745 }
12746
12747 uiout->text (" at ");
12748 ada_find_printable_frame (get_current_frame ());
12749
12750 return PRINT_SRC_AND_LOC;
12751 }
12752
12753 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12754 for all exception catchpoint kinds. */
12755
12756 static void
12757 print_one_exception (enum ada_exception_catchpoint_kind ex,
12758 struct breakpoint *b, struct bp_location **last_loc)
12759 {
12760 struct ui_out *uiout = current_uiout;
12761 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12762 struct value_print_options opts;
12763
12764 get_user_print_options (&opts);
12765 if (opts.addressprint)
12766 {
12767 annotate_field (4);
12768 uiout->field_core_addr ("addr", b->loc->gdbarch, b->loc->address);
12769 }
12770
12771 annotate_field (5);
12772 *last_loc = b->loc;
12773 switch (ex)
12774 {
12775 case ada_catch_exception:
12776 if (c->excep_string != NULL)
12777 {
12778 char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12779
12780 uiout->field_string ("what", msg);
12781 xfree (msg);
12782 }
12783 else
12784 uiout->field_string ("what", "all Ada exceptions");
12785
12786 break;
12787
12788 case ada_catch_exception_unhandled:
12789 uiout->field_string ("what", "unhandled Ada exceptions");
12790 break;
12791
12792 case ada_catch_handlers:
12793 if (c->excep_string != NULL)
12794 {
12795 uiout->field_fmt ("what",
12796 _("`%s' Ada exception handlers"),
12797 c->excep_string);
12798 }
12799 else
12800 uiout->field_string ("what", "all Ada exceptions handlers");
12801 break;
12802
12803 case ada_catch_assert:
12804 uiout->field_string ("what", "failed Ada assertions");
12805 break;
12806
12807 default:
12808 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12809 break;
12810 }
12811 }
12812
12813 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12814 for all exception catchpoint kinds. */
12815
12816 static void
12817 print_mention_exception (enum ada_exception_catchpoint_kind ex,
12818 struct breakpoint *b)
12819 {
12820 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12821 struct ui_out *uiout = current_uiout;
12822
12823 uiout->text (b->disposition == disp_del ? _("Temporary catchpoint ")
12824 : _("Catchpoint "));
12825 uiout->field_int ("bkptno", b->number);
12826 uiout->text (": ");
12827
12828 switch (ex)
12829 {
12830 case ada_catch_exception:
12831 if (c->excep_string != NULL)
12832 {
12833 char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12834 struct cleanup *old_chain = make_cleanup (xfree, info);
12835
12836 uiout->text (info);
12837 do_cleanups (old_chain);
12838 }
12839 else
12840 uiout->text (_("all Ada exceptions"));
12841 break;
12842
12843 case ada_catch_exception_unhandled:
12844 uiout->text (_("unhandled Ada exceptions"));
12845 break;
12846
12847 case ada_catch_handlers:
12848 if (c->excep_string != NULL)
12849 {
12850 std::string info
12851 = string_printf (_("`%s' Ada exception handlers"),
12852 c->excep_string);
12853 uiout->text (info.c_str ());
12854 }
12855 else
12856 uiout->text (_("all Ada exceptions handlers"));
12857 break;
12858
12859 case ada_catch_assert:
12860 uiout->text (_("failed Ada assertions"));
12861 break;
12862
12863 default:
12864 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12865 break;
12866 }
12867 }
12868
12869 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12870 for all exception catchpoint kinds. */
12871
12872 static void
12873 print_recreate_exception (enum ada_exception_catchpoint_kind ex,
12874 struct breakpoint *b, struct ui_file *fp)
12875 {
12876 struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12877
12878 switch (ex)
12879 {
12880 case ada_catch_exception:
12881 fprintf_filtered (fp, "catch exception");
12882 if (c->excep_string != NULL)
12883 fprintf_filtered (fp, " %s", c->excep_string);
12884 break;
12885
12886 case ada_catch_exception_unhandled:
12887 fprintf_filtered (fp, "catch exception unhandled");
12888 break;
12889
12890 case ada_catch_handlers:
12891 fprintf_filtered (fp, "catch handlers");
12892 break;
12893
12894 case ada_catch_assert:
12895 fprintf_filtered (fp, "catch assert");
12896 break;
12897
12898 default:
12899 internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12900 }
12901 print_recreate_thread (b, fp);
12902 }
12903
12904 /* Virtual table for "catch exception" breakpoints. */
12905
12906 static struct bp_location *
12907 allocate_location_catch_exception (struct breakpoint *self)
12908 {
12909 return allocate_location_exception (ada_catch_exception, self);
12910 }
12911
12912 static void
12913 re_set_catch_exception (struct breakpoint *b)
12914 {
12915 re_set_exception (ada_catch_exception, b);
12916 }
12917
12918 static void
12919 check_status_catch_exception (bpstat bs)
12920 {
12921 check_status_exception (ada_catch_exception, bs);
12922 }
12923
12924 static enum print_stop_action
12925 print_it_catch_exception (bpstat bs)
12926 {
12927 return print_it_exception (ada_catch_exception, bs);
12928 }
12929
12930 static void
12931 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
12932 {
12933 print_one_exception (ada_catch_exception, b, last_loc);
12934 }
12935
12936 static void
12937 print_mention_catch_exception (struct breakpoint *b)
12938 {
12939 print_mention_exception (ada_catch_exception, b);
12940 }
12941
12942 static void
12943 print_recreate_catch_exception (struct breakpoint *b, struct ui_file *fp)
12944 {
12945 print_recreate_exception (ada_catch_exception, b, fp);
12946 }
12947
12948 static struct breakpoint_ops catch_exception_breakpoint_ops;
12949
12950 /* Virtual table for "catch exception unhandled" breakpoints. */
12951
12952 static struct bp_location *
12953 allocate_location_catch_exception_unhandled (struct breakpoint *self)
12954 {
12955 return allocate_location_exception (ada_catch_exception_unhandled, self);
12956 }
12957
12958 static void
12959 re_set_catch_exception_unhandled (struct breakpoint *b)
12960 {
12961 re_set_exception (ada_catch_exception_unhandled, b);
12962 }
12963
12964 static void
12965 check_status_catch_exception_unhandled (bpstat bs)
12966 {
12967 check_status_exception (ada_catch_exception_unhandled, bs);
12968 }
12969
12970 static enum print_stop_action
12971 print_it_catch_exception_unhandled (bpstat bs)
12972 {
12973 return print_it_exception (ada_catch_exception_unhandled, bs);
12974 }
12975
12976 static void
12977 print_one_catch_exception_unhandled (struct breakpoint *b,
12978 struct bp_location **last_loc)
12979 {
12980 print_one_exception (ada_catch_exception_unhandled, b, last_loc);
12981 }
12982
12983 static void
12984 print_mention_catch_exception_unhandled (struct breakpoint *b)
12985 {
12986 print_mention_exception (ada_catch_exception_unhandled, b);
12987 }
12988
12989 static void
12990 print_recreate_catch_exception_unhandled (struct breakpoint *b,
12991 struct ui_file *fp)
12992 {
12993 print_recreate_exception (ada_catch_exception_unhandled, b, fp);
12994 }
12995
12996 static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops;
12997
12998 /* Virtual table for "catch assert" breakpoints. */
12999
13000 static struct bp_location *
13001 allocate_location_catch_assert (struct breakpoint *self)
13002 {
13003 return allocate_location_exception (ada_catch_assert, self);
13004 }
13005
13006 static void
13007 re_set_catch_assert (struct breakpoint *b)
13008 {
13009 re_set_exception (ada_catch_assert, b);
13010 }
13011
13012 static void
13013 check_status_catch_assert (bpstat bs)
13014 {
13015 check_status_exception (ada_catch_assert, bs);
13016 }
13017
13018 static enum print_stop_action
13019 print_it_catch_assert (bpstat bs)
13020 {
13021 return print_it_exception (ada_catch_assert, bs);
13022 }
13023
13024 static void
13025 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
13026 {
13027 print_one_exception (ada_catch_assert, b, last_loc);
13028 }
13029
13030 static void
13031 print_mention_catch_assert (struct breakpoint *b)
13032 {
13033 print_mention_exception (ada_catch_assert, b);
13034 }
13035
13036 static void
13037 print_recreate_catch_assert (struct breakpoint *b, struct ui_file *fp)
13038 {
13039 print_recreate_exception (ada_catch_assert, b, fp);
13040 }
13041
13042 static struct breakpoint_ops catch_assert_breakpoint_ops;
13043
13044 /* Virtual table for "catch handlers" breakpoints. */
13045
13046 static struct bp_location *
13047 allocate_location_catch_handlers (struct breakpoint *self)
13048 {
13049 return allocate_location_exception (ada_catch_handlers, self);
13050 }
13051
13052 static void
13053 re_set_catch_handlers (struct breakpoint *b)
13054 {
13055 re_set_exception (ada_catch_handlers, b);
13056 }
13057
13058 static void
13059 check_status_catch_handlers (bpstat bs)
13060 {
13061 check_status_exception (ada_catch_handlers, bs);
13062 }
13063
13064 static enum print_stop_action
13065 print_it_catch_handlers (bpstat bs)
13066 {
13067 return print_it_exception (ada_catch_handlers, bs);
13068 }
13069
13070 static void
13071 print_one_catch_handlers (struct breakpoint *b,
13072 struct bp_location **last_loc)
13073 {
13074 print_one_exception (ada_catch_handlers, b, last_loc);
13075 }
13076
13077 static void
13078 print_mention_catch_handlers (struct breakpoint *b)
13079 {
13080 print_mention_exception (ada_catch_handlers, b);
13081 }
13082
13083 static void
13084 print_recreate_catch_handlers (struct breakpoint *b,
13085 struct ui_file *fp)
13086 {
13087 print_recreate_exception (ada_catch_handlers, b, fp);
13088 }
13089
13090 static struct breakpoint_ops catch_handlers_breakpoint_ops;
13091
13092 /* Return a newly allocated copy of the first space-separated token
13093 in ARGSP, and then adjust ARGSP to point immediately after that
13094 token.
13095
13096 Return NULL if ARGPS does not contain any more tokens. */
13097
13098 static char *
13099 ada_get_next_arg (const char **argsp)
13100 {
13101 const char *args = *argsp;
13102 const char *end;
13103 char *result;
13104
13105 args = skip_spaces (args);
13106 if (args[0] == '\0')
13107 return NULL; /* No more arguments. */
13108
13109 /* Find the end of the current argument. */
13110
13111 end = skip_to_space (args);
13112
13113 /* Adjust ARGSP to point to the start of the next argument. */
13114
13115 *argsp = end;
13116
13117 /* Make a copy of the current argument and return it. */
13118
13119 result = (char *) xmalloc (end - args + 1);
13120 strncpy (result, args, end - args);
13121 result[end - args] = '\0';
13122
13123 return result;
13124 }
13125
13126 /* Split the arguments specified in a "catch exception" command.
13127 Set EX to the appropriate catchpoint type.
13128 Set EXCEP_STRING to the name of the specific exception if
13129 specified by the user.
13130 IS_CATCH_HANDLERS_CMD: True if the arguments are for a
13131 "catch handlers" command. False otherwise.
13132 If a condition is found at the end of the arguments, the condition
13133 expression is stored in COND_STRING (memory must be deallocated
13134 after use). Otherwise COND_STRING is set to NULL. */
13135
13136 static void
13137 catch_ada_exception_command_split (const char *args,
13138 bool is_catch_handlers_cmd,
13139 enum ada_exception_catchpoint_kind *ex,
13140 char **excep_string,
13141 char **cond_string)
13142 {
13143 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
13144 char *exception_name;
13145 char *cond = NULL;
13146
13147 exception_name = ada_get_next_arg (&args);
13148 if (exception_name != NULL && strcmp (exception_name, "if") == 0)
13149 {
13150 /* This is not an exception name; this is the start of a condition
13151 expression for a catchpoint on all exceptions. So, "un-get"
13152 this token, and set exception_name to NULL. */
13153 xfree (exception_name);
13154 exception_name = NULL;
13155 args -= 2;
13156 }
13157 make_cleanup (xfree, exception_name);
13158
13159 /* Check to see if we have a condition. */
13160
13161 args = skip_spaces (args);
13162 if (startswith (args, "if")
13163 && (isspace (args[2]) || args[2] == '\0'))
13164 {
13165 args += 2;
13166 args = skip_spaces (args);
13167
13168 if (args[0] == '\0')
13169 error (_("Condition missing after `if' keyword"));
13170 cond = xstrdup (args);
13171 make_cleanup (xfree, cond);
13172
13173 args += strlen (args);
13174 }
13175
13176 /* Check that we do not have any more arguments. Anything else
13177 is unexpected. */
13178
13179 if (args[0] != '\0')
13180 error (_("Junk at end of expression"));
13181
13182 discard_cleanups (old_chain);
13183
13184 if (is_catch_handlers_cmd)
13185 {
13186 /* Catch handling of exceptions. */
13187 *ex = ada_catch_handlers;
13188 *excep_string = exception_name;
13189 }
13190 else if (exception_name == NULL)
13191 {
13192 /* Catch all exceptions. */
13193 *ex = ada_catch_exception;
13194 *excep_string = NULL;
13195 }
13196 else if (strcmp (exception_name, "unhandled") == 0)
13197 {
13198 /* Catch unhandled exceptions. */
13199 *ex = ada_catch_exception_unhandled;
13200 *excep_string = NULL;
13201 }
13202 else
13203 {
13204 /* Catch a specific exception. */
13205 *ex = ada_catch_exception;
13206 *excep_string = exception_name;
13207 }
13208 *cond_string = cond;
13209 }
13210
13211 /* Return the name of the symbol on which we should break in order to
13212 implement a catchpoint of the EX kind. */
13213
13214 static const char *
13215 ada_exception_sym_name (enum ada_exception_catchpoint_kind ex)
13216 {
13217 struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
13218
13219 gdb_assert (data->exception_info != NULL);
13220
13221 switch (ex)
13222 {
13223 case ada_catch_exception:
13224 return (data->exception_info->catch_exception_sym);
13225 break;
13226 case ada_catch_exception_unhandled:
13227 return (data->exception_info->catch_exception_unhandled_sym);
13228 break;
13229 case ada_catch_assert:
13230 return (data->exception_info->catch_assert_sym);
13231 break;
13232 case ada_catch_handlers:
13233 return (data->exception_info->catch_handlers_sym);
13234 break;
13235 default:
13236 internal_error (__FILE__, __LINE__,
13237 _("unexpected catchpoint kind (%d)"), ex);
13238 }
13239 }
13240
13241 /* Return the breakpoint ops "virtual table" used for catchpoints
13242 of the EX kind. */
13243
13244 static const struct breakpoint_ops *
13245 ada_exception_breakpoint_ops (enum ada_exception_catchpoint_kind ex)
13246 {
13247 switch (ex)
13248 {
13249 case ada_catch_exception:
13250 return (&catch_exception_breakpoint_ops);
13251 break;
13252 case ada_catch_exception_unhandled:
13253 return (&catch_exception_unhandled_breakpoint_ops);
13254 break;
13255 case ada_catch_assert:
13256 return (&catch_assert_breakpoint_ops);
13257 break;
13258 case ada_catch_handlers:
13259 return (&catch_handlers_breakpoint_ops);
13260 break;
13261 default:
13262 internal_error (__FILE__, __LINE__,
13263 _("unexpected catchpoint kind (%d)"), ex);
13264 }
13265 }
13266
13267 /* Return the condition that will be used to match the current exception
13268 being raised with the exception that the user wants to catch. This
13269 assumes that this condition is used when the inferior just triggered
13270 an exception catchpoint.
13271 EX: the type of catchpoints used for catching Ada exceptions.
13272
13273 The string returned is a newly allocated string that needs to be
13274 deallocated later. */
13275
13276 static char *
13277 ada_exception_catchpoint_cond_string (const char *excep_string,
13278 enum ada_exception_catchpoint_kind ex)
13279 {
13280 int i;
13281 bool is_standard_exc = false;
13282 const char *actual_exc_expr;
13283 char *ref_exc_expr;
13284
13285 if (ex == ada_catch_handlers)
13286 {
13287 /* For exception handlers catchpoints, the condition string does
13288 not use the same parameter as for the other exceptions. */
13289 actual_exc_expr = ("long_integer (GNAT_GCC_exception_Access"
13290 "(gcc_exception).all.occurrence.id)");
13291 }
13292 else
13293 actual_exc_expr = "long_integer (e)";
13294
13295 /* The standard exceptions are a special case. They are defined in
13296 runtime units that have been compiled without debugging info; if
13297 EXCEP_STRING is the not-fully-qualified name of a standard
13298 exception (e.g. "constraint_error") then, during the evaluation
13299 of the condition expression, the symbol lookup on this name would
13300 *not* return this standard exception. The catchpoint condition
13301 may then be set only on user-defined exceptions which have the
13302 same not-fully-qualified name (e.g. my_package.constraint_error).
13303
13304 To avoid this unexcepted behavior, these standard exceptions are
13305 systematically prefixed by "standard". This means that "catch
13306 exception constraint_error" is rewritten into "catch exception
13307 standard.constraint_error".
13308
13309 If an exception named contraint_error is defined in another package of
13310 the inferior program, then the only way to specify this exception as a
13311 breakpoint condition is to use its fully-qualified named:
13312 e.g. my_package.constraint_error. */
13313
13314 for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
13315 {
13316 if (strcmp (standard_exc [i], excep_string) == 0)
13317 {
13318 is_standard_exc = true;
13319 break;
13320 }
13321 }
13322
13323 if (is_standard_exc)
13324 ref_exc_expr = xstrprintf ("long_integer (&standard.%s)", excep_string);
13325 else
13326 ref_exc_expr = xstrprintf ("long_integer (&%s)", excep_string);
13327
13328 char *result = xstrprintf ("%s = %s", actual_exc_expr, ref_exc_expr);
13329 xfree (ref_exc_expr);
13330 return result;
13331 }
13332
13333 /* Return the symtab_and_line that should be used to insert an exception
13334 catchpoint of the TYPE kind.
13335
13336 EXCEP_STRING should contain the name of a specific exception that
13337 the catchpoint should catch, or NULL otherwise.
13338
13339 ADDR_STRING returns the name of the function where the real
13340 breakpoint that implements the catchpoints is set, depending on the
13341 type of catchpoint we need to create. */
13342
13343 static struct symtab_and_line
13344 ada_exception_sal (enum ada_exception_catchpoint_kind ex, char *excep_string,
13345 const char **addr_string, const struct breakpoint_ops **ops)
13346 {
13347 const char *sym_name;
13348 struct symbol *sym;
13349
13350 /* First, find out which exception support info to use. */
13351 ada_exception_support_info_sniffer ();
13352
13353 /* Then lookup the function on which we will break in order to catch
13354 the Ada exceptions requested by the user. */
13355 sym_name = ada_exception_sym_name (ex);
13356 sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
13357
13358 /* We can assume that SYM is not NULL at this stage. If the symbol
13359 did not exist, ada_exception_support_info_sniffer would have
13360 raised an exception.
13361
13362 Also, ada_exception_support_info_sniffer should have already
13363 verified that SYM is a function symbol. */
13364 gdb_assert (sym != NULL);
13365 gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
13366
13367 /* Set ADDR_STRING. */
13368 *addr_string = xstrdup (sym_name);
13369
13370 /* Set OPS. */
13371 *ops = ada_exception_breakpoint_ops (ex);
13372
13373 return find_function_start_sal (sym, 1);
13374 }
13375
13376 /* Create an Ada exception catchpoint.
13377
13378 EX_KIND is the kind of exception catchpoint to be created.
13379
13380 If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
13381 for all exceptions. Otherwise, EXCEPT_STRING indicates the name
13382 of the exception to which this catchpoint applies. When not NULL,
13383 the string must be allocated on the heap, and its deallocation
13384 is no longer the responsibility of the caller.
13385
13386 COND_STRING, if not NULL, is the catchpoint condition. This string
13387 must be allocated on the heap, and its deallocation is no longer
13388 the responsibility of the caller.
13389
13390 TEMPFLAG, if nonzero, means that the underlying breakpoint
13391 should be temporary.
13392
13393 FROM_TTY is the usual argument passed to all commands implementations. */
13394
13395 void
13396 create_ada_exception_catchpoint (struct gdbarch *gdbarch,
13397 enum ada_exception_catchpoint_kind ex_kind,
13398 char *excep_string,
13399 char *cond_string,
13400 int tempflag,
13401 int disabled,
13402 int from_tty)
13403 {
13404 const char *addr_string = NULL;
13405 const struct breakpoint_ops *ops = NULL;
13406 struct symtab_and_line sal
13407 = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
13408
13409 std::unique_ptr<ada_catchpoint> c (new ada_catchpoint ());
13410 init_ada_exception_breakpoint (c.get (), gdbarch, sal, addr_string,
13411 ops, tempflag, disabled, from_tty);
13412 c->excep_string = excep_string;
13413 create_excep_cond_exprs (c.get (), ex_kind);
13414 if (cond_string != NULL)
13415 set_breakpoint_condition (c.get (), cond_string, from_tty);
13416 install_breakpoint (0, std::move (c), 1);
13417 }
13418
13419 /* Implement the "catch exception" command. */
13420
13421 static void
13422 catch_ada_exception_command (const char *arg_entry, int from_tty,
13423 struct cmd_list_element *command)
13424 {
13425 const char *arg = arg_entry;
13426 struct gdbarch *gdbarch = get_current_arch ();
13427 int tempflag;
13428 enum ada_exception_catchpoint_kind ex_kind;
13429 char *excep_string = NULL;
13430 char *cond_string = NULL;
13431
13432 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13433
13434 if (!arg)
13435 arg = "";
13436 catch_ada_exception_command_split (arg, false, &ex_kind, &excep_string,
13437 &cond_string);
13438 create_ada_exception_catchpoint (gdbarch, ex_kind,
13439 excep_string, cond_string,
13440 tempflag, 1 /* enabled */,
13441 from_tty);
13442 }
13443
13444 /* Implement the "catch handlers" command. */
13445
13446 static void
13447 catch_ada_handlers_command (const char *arg_entry, int from_tty,
13448 struct cmd_list_element *command)
13449 {
13450 const char *arg = arg_entry;
13451 struct gdbarch *gdbarch = get_current_arch ();
13452 int tempflag;
13453 enum ada_exception_catchpoint_kind ex_kind;
13454 char *excep_string = NULL;
13455 char *cond_string = NULL;
13456
13457 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13458
13459 if (!arg)
13460 arg = "";
13461 catch_ada_exception_command_split (arg, true, &ex_kind, &excep_string,
13462 &cond_string);
13463 create_ada_exception_catchpoint (gdbarch, ex_kind,
13464 excep_string, cond_string,
13465 tempflag, 1 /* enabled */,
13466 from_tty);
13467 }
13468
13469 /* Split the arguments specified in a "catch assert" command.
13470
13471 ARGS contains the command's arguments (or the empty string if
13472 no arguments were passed).
13473
13474 If ARGS contains a condition, set COND_STRING to that condition
13475 (the memory needs to be deallocated after use). */
13476
13477 static void
13478 catch_ada_assert_command_split (const char *args, char **cond_string)
13479 {
13480 args = skip_spaces (args);
13481
13482 /* Check whether a condition was provided. */
13483 if (startswith (args, "if")
13484 && (isspace (args[2]) || args[2] == '\0'))
13485 {
13486 args += 2;
13487 args = skip_spaces (args);
13488 if (args[0] == '\0')
13489 error (_("condition missing after `if' keyword"));
13490 *cond_string = xstrdup (args);
13491 }
13492
13493 /* Otherwise, there should be no other argument at the end of
13494 the command. */
13495 else if (args[0] != '\0')
13496 error (_("Junk at end of arguments."));
13497 }
13498
13499 /* Implement the "catch assert" command. */
13500
13501 static void
13502 catch_assert_command (const char *arg_entry, int from_tty,
13503 struct cmd_list_element *command)
13504 {
13505 const char *arg = arg_entry;
13506 struct gdbarch *gdbarch = get_current_arch ();
13507 int tempflag;
13508 char *cond_string = NULL;
13509
13510 tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
13511
13512 if (!arg)
13513 arg = "";
13514 catch_ada_assert_command_split (arg, &cond_string);
13515 create_ada_exception_catchpoint (gdbarch, ada_catch_assert,
13516 NULL, cond_string,
13517 tempflag, 1 /* enabled */,
13518 from_tty);
13519 }
13520
13521 /* Return non-zero if the symbol SYM is an Ada exception object. */
13522
13523 static int
13524 ada_is_exception_sym (struct symbol *sym)
13525 {
13526 const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
13527
13528 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
13529 && SYMBOL_CLASS (sym) != LOC_BLOCK
13530 && SYMBOL_CLASS (sym) != LOC_CONST
13531 && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
13532 && type_name != NULL && strcmp (type_name, "exception") == 0);
13533 }
13534
13535 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
13536 Ada exception object. This matches all exceptions except the ones
13537 defined by the Ada language. */
13538
13539 static int
13540 ada_is_non_standard_exception_sym (struct symbol *sym)
13541 {
13542 int i;
13543
13544 if (!ada_is_exception_sym (sym))
13545 return 0;
13546
13547 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13548 if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
13549 return 0; /* A standard exception. */
13550
13551 /* Numeric_Error is also a standard exception, so exclude it.
13552 See the STANDARD_EXC description for more details as to why
13553 this exception is not listed in that array. */
13554 if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
13555 return 0;
13556
13557 return 1;
13558 }
13559
13560 /* A helper function for std::sort, comparing two struct ada_exc_info
13561 objects.
13562
13563 The comparison is determined first by exception name, and then
13564 by exception address. */
13565
13566 bool
13567 ada_exc_info::operator< (const ada_exc_info &other) const
13568 {
13569 int result;
13570
13571 result = strcmp (name, other.name);
13572 if (result < 0)
13573 return true;
13574 if (result == 0 && addr < other.addr)
13575 return true;
13576 return false;
13577 }
13578
13579 bool
13580 ada_exc_info::operator== (const ada_exc_info &other) const
13581 {
13582 return addr == other.addr && strcmp (name, other.name) == 0;
13583 }
13584
13585 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
13586 routine, but keeping the first SKIP elements untouched.
13587
13588 All duplicates are also removed. */
13589
13590 static void
13591 sort_remove_dups_ada_exceptions_list (std::vector<ada_exc_info> *exceptions,
13592 int skip)
13593 {
13594 std::sort (exceptions->begin () + skip, exceptions->end ());
13595 exceptions->erase (std::unique (exceptions->begin () + skip, exceptions->end ()),
13596 exceptions->end ());
13597 }
13598
13599 /* Add all exceptions defined by the Ada standard whose name match
13600 a regular expression.
13601
13602 If PREG is not NULL, then this regexp_t object is used to
13603 perform the symbol name matching. Otherwise, no name-based
13604 filtering is performed.
13605
13606 EXCEPTIONS is a vector of exceptions to which matching exceptions
13607 gets pushed. */
13608
13609 static void
13610 ada_add_standard_exceptions (compiled_regex *preg,
13611 std::vector<ada_exc_info> *exceptions)
13612 {
13613 int i;
13614
13615 for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13616 {
13617 if (preg == NULL
13618 || preg->exec (standard_exc[i], 0, NULL, 0) == 0)
13619 {
13620 struct bound_minimal_symbol msymbol
13621 = ada_lookup_simple_minsym (standard_exc[i]);
13622
13623 if (msymbol.minsym != NULL)
13624 {
13625 struct ada_exc_info info
13626 = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
13627
13628 exceptions->push_back (info);
13629 }
13630 }
13631 }
13632 }
13633
13634 /* Add all Ada exceptions defined locally and accessible from the given
13635 FRAME.
13636
13637 If PREG is not NULL, then this regexp_t object is used to
13638 perform the symbol name matching. Otherwise, no name-based
13639 filtering is performed.
13640
13641 EXCEPTIONS is a vector of exceptions to which matching exceptions
13642 gets pushed. */
13643
13644 static void
13645 ada_add_exceptions_from_frame (compiled_regex *preg,
13646 struct frame_info *frame,
13647 std::vector<ada_exc_info> *exceptions)
13648 {
13649 const struct block *block = get_frame_block (frame, 0);
13650
13651 while (block != 0)
13652 {
13653 struct block_iterator iter;
13654 struct symbol *sym;
13655
13656 ALL_BLOCK_SYMBOLS (block, iter, sym)
13657 {
13658 switch (SYMBOL_CLASS (sym))
13659 {
13660 case LOC_TYPEDEF:
13661 case LOC_BLOCK:
13662 case LOC_CONST:
13663 break;
13664 default:
13665 if (ada_is_exception_sym (sym))
13666 {
13667 struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13668 SYMBOL_VALUE_ADDRESS (sym)};
13669
13670 exceptions->push_back (info);
13671 }
13672 }
13673 }
13674 if (BLOCK_FUNCTION (block) != NULL)
13675 break;
13676 block = BLOCK_SUPERBLOCK (block);
13677 }
13678 }
13679
13680 /* Return true if NAME matches PREG or if PREG is NULL. */
13681
13682 static bool
13683 name_matches_regex (const char *name, compiled_regex *preg)
13684 {
13685 return (preg == NULL
13686 || preg->exec (ada_decode (name), 0, NULL, 0) == 0);
13687 }
13688
13689 /* Add all exceptions defined globally whose name name match
13690 a regular expression, excluding standard exceptions.
13691
13692 The reason we exclude standard exceptions is that they need
13693 to be handled separately: Standard exceptions are defined inside
13694 a runtime unit which is normally not compiled with debugging info,
13695 and thus usually do not show up in our symbol search. However,
13696 if the unit was in fact built with debugging info, we need to
13697 exclude them because they would duplicate the entry we found
13698 during the special loop that specifically searches for those
13699 standard exceptions.
13700
13701 If PREG is not NULL, then this regexp_t object is used to
13702 perform the symbol name matching. Otherwise, no name-based
13703 filtering is performed.
13704
13705 EXCEPTIONS is a vector of exceptions to which matching exceptions
13706 gets pushed. */
13707
13708 static void
13709 ada_add_global_exceptions (compiled_regex *preg,
13710 std::vector<ada_exc_info> *exceptions)
13711 {
13712 struct objfile *objfile;
13713 struct compunit_symtab *s;
13714
13715 /* In Ada, the symbol "search name" is a linkage name, whereas the
13716 regular expression used to do the matching refers to the natural
13717 name. So match against the decoded name. */
13718 expand_symtabs_matching (NULL,
13719 lookup_name_info::match_any (),
13720 [&] (const char *search_name)
13721 {
13722 const char *decoded = ada_decode (search_name);
13723 return name_matches_regex (decoded, preg);
13724 },
13725 NULL,
13726 VARIABLES_DOMAIN);
13727
13728 ALL_COMPUNITS (objfile, s)
13729 {
13730 const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13731 int i;
13732
13733 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13734 {
13735 struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13736 struct block_iterator iter;
13737 struct symbol *sym;
13738
13739 ALL_BLOCK_SYMBOLS (b, iter, sym)
13740 if (ada_is_non_standard_exception_sym (sym)
13741 && name_matches_regex (SYMBOL_NATURAL_NAME (sym), preg))
13742 {
13743 struct ada_exc_info info
13744 = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13745
13746 exceptions->push_back (info);
13747 }
13748 }
13749 }
13750 }
13751
13752 /* Implements ada_exceptions_list with the regular expression passed
13753 as a regex_t, rather than a string.
13754
13755 If not NULL, PREG is used to filter out exceptions whose names
13756 do not match. Otherwise, all exceptions are listed. */
13757
13758 static std::vector<ada_exc_info>
13759 ada_exceptions_list_1 (compiled_regex *preg)
13760 {
13761 std::vector<ada_exc_info> result;
13762 int prev_len;
13763
13764 /* First, list the known standard exceptions. These exceptions
13765 need to be handled separately, as they are usually defined in
13766 runtime units that have been compiled without debugging info. */
13767
13768 ada_add_standard_exceptions (preg, &result);
13769
13770 /* Next, find all exceptions whose scope is local and accessible
13771 from the currently selected frame. */
13772
13773 if (has_stack_frames ())
13774 {
13775 prev_len = result.size ();
13776 ada_add_exceptions_from_frame (preg, get_selected_frame (NULL),
13777 &result);
13778 if (result.size () > prev_len)
13779 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13780 }
13781
13782 /* Add all exceptions whose scope is global. */
13783
13784 prev_len = result.size ();
13785 ada_add_global_exceptions (preg, &result);
13786 if (result.size () > prev_len)
13787 sort_remove_dups_ada_exceptions_list (&result, prev_len);
13788
13789 return result;
13790 }
13791
13792 /* Return a vector of ada_exc_info.
13793
13794 If REGEXP is NULL, all exceptions are included in the result.
13795 Otherwise, it should contain a valid regular expression,
13796 and only the exceptions whose names match that regular expression
13797 are included in the result.
13798
13799 The exceptions are sorted in the following order:
13800 - Standard exceptions (defined by the Ada language), in
13801 alphabetical order;
13802 - Exceptions only visible from the current frame, in
13803 alphabetical order;
13804 - Exceptions whose scope is global, in alphabetical order. */
13805
13806 std::vector<ada_exc_info>
13807 ada_exceptions_list (const char *regexp)
13808 {
13809 if (regexp == NULL)
13810 return ada_exceptions_list_1 (NULL);
13811
13812 compiled_regex reg (regexp, REG_NOSUB, _("invalid regular expression"));
13813 return ada_exceptions_list_1 (&reg);
13814 }
13815
13816 /* Implement the "info exceptions" command. */
13817
13818 static void
13819 info_exceptions_command (const char *regexp, int from_tty)
13820 {
13821 struct gdbarch *gdbarch = get_current_arch ();
13822
13823 std::vector<ada_exc_info> exceptions = ada_exceptions_list (regexp);
13824
13825 if (regexp != NULL)
13826 printf_filtered
13827 (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13828 else
13829 printf_filtered (_("All defined Ada exceptions:\n"));
13830
13831 for (const ada_exc_info &info : exceptions)
13832 printf_filtered ("%s: %s\n", info.name, paddress (gdbarch, info.addr));
13833 }
13834
13835 /* Operators */
13836 /* Information about operators given special treatment in functions
13837 below. */
13838 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13839
13840 #define ADA_OPERATORS \
13841 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13842 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13843 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13844 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13845 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13846 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13847 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13848 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13849 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13850 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13851 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13852 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13853 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13854 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13855 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13856 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13857 OP_DEFN (OP_OTHERS, 1, 1, 0) \
13858 OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13859 OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13860
13861 static void
13862 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13863 int *argsp)
13864 {
13865 switch (exp->elts[pc - 1].opcode)
13866 {
13867 default:
13868 operator_length_standard (exp, pc, oplenp, argsp);
13869 break;
13870
13871 #define OP_DEFN(op, len, args, binop) \
13872 case op: *oplenp = len; *argsp = args; break;
13873 ADA_OPERATORS;
13874 #undef OP_DEFN
13875
13876 case OP_AGGREGATE:
13877 *oplenp = 3;
13878 *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13879 break;
13880
13881 case OP_CHOICES:
13882 *oplenp = 3;
13883 *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13884 break;
13885 }
13886 }
13887
13888 /* Implementation of the exp_descriptor method operator_check. */
13889
13890 static int
13891 ada_operator_check (struct expression *exp, int pos,
13892 int (*objfile_func) (struct objfile *objfile, void *data),
13893 void *data)
13894 {
13895 const union exp_element *const elts = exp->elts;
13896 struct type *type = NULL;
13897
13898 switch (elts[pos].opcode)
13899 {
13900 case UNOP_IN_RANGE:
13901 case UNOP_QUAL:
13902 type = elts[pos + 1].type;
13903 break;
13904
13905 default:
13906 return operator_check_standard (exp, pos, objfile_func, data);
13907 }
13908
13909 /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13910
13911 if (type && TYPE_OBJFILE (type)
13912 && (*objfile_func) (TYPE_OBJFILE (type), data))
13913 return 1;
13914
13915 return 0;
13916 }
13917
13918 static const char *
13919 ada_op_name (enum exp_opcode opcode)
13920 {
13921 switch (opcode)
13922 {
13923 default:
13924 return op_name_standard (opcode);
13925
13926 #define OP_DEFN(op, len, args, binop) case op: return #op;
13927 ADA_OPERATORS;
13928 #undef OP_DEFN
13929
13930 case OP_AGGREGATE:
13931 return "OP_AGGREGATE";
13932 case OP_CHOICES:
13933 return "OP_CHOICES";
13934 case OP_NAME:
13935 return "OP_NAME";
13936 }
13937 }
13938
13939 /* As for operator_length, but assumes PC is pointing at the first
13940 element of the operator, and gives meaningful results only for the
13941 Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13942
13943 static void
13944 ada_forward_operator_length (struct expression *exp, int pc,
13945 int *oplenp, int *argsp)
13946 {
13947 switch (exp->elts[pc].opcode)
13948 {
13949 default:
13950 *oplenp = *argsp = 0;
13951 break;
13952
13953 #define OP_DEFN(op, len, args, binop) \
13954 case op: *oplenp = len; *argsp = args; break;
13955 ADA_OPERATORS;
13956 #undef OP_DEFN
13957
13958 case OP_AGGREGATE:
13959 *oplenp = 3;
13960 *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13961 break;
13962
13963 case OP_CHOICES:
13964 *oplenp = 3;
13965 *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13966 break;
13967
13968 case OP_STRING:
13969 case OP_NAME:
13970 {
13971 int len = longest_to_int (exp->elts[pc + 1].longconst);
13972
13973 *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13974 *argsp = 0;
13975 break;
13976 }
13977 }
13978 }
13979
13980 static int
13981 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13982 {
13983 enum exp_opcode op = exp->elts[elt].opcode;
13984 int oplen, nargs;
13985 int pc = elt;
13986 int i;
13987
13988 ada_forward_operator_length (exp, elt, &oplen, &nargs);
13989
13990 switch (op)
13991 {
13992 /* Ada attributes ('Foo). */
13993 case OP_ATR_FIRST:
13994 case OP_ATR_LAST:
13995 case OP_ATR_LENGTH:
13996 case OP_ATR_IMAGE:
13997 case OP_ATR_MAX:
13998 case OP_ATR_MIN:
13999 case OP_ATR_MODULUS:
14000 case OP_ATR_POS:
14001 case OP_ATR_SIZE:
14002 case OP_ATR_TAG:
14003 case OP_ATR_VAL:
14004 break;
14005
14006 case UNOP_IN_RANGE:
14007 case UNOP_QUAL:
14008 /* XXX: gdb_sprint_host_address, type_sprint */
14009 fprintf_filtered (stream, _("Type @"));
14010 gdb_print_host_address (exp->elts[pc + 1].type, stream);
14011 fprintf_filtered (stream, " (");
14012 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
14013 fprintf_filtered (stream, ")");
14014 break;
14015 case BINOP_IN_BOUNDS:
14016 fprintf_filtered (stream, " (%d)",
14017 longest_to_int (exp->elts[pc + 2].longconst));
14018 break;
14019 case TERNOP_IN_RANGE:
14020 break;
14021
14022 case OP_AGGREGATE:
14023 case OP_OTHERS:
14024 case OP_DISCRETE_RANGE:
14025 case OP_POSITIONAL:
14026 case OP_CHOICES:
14027 break;
14028
14029 case OP_NAME:
14030 case OP_STRING:
14031 {
14032 char *name = &exp->elts[elt + 2].string;
14033 int len = longest_to_int (exp->elts[elt + 1].longconst);
14034
14035 fprintf_filtered (stream, "Text: `%.*s'", len, name);
14036 break;
14037 }
14038
14039 default:
14040 return dump_subexp_body_standard (exp, stream, elt);
14041 }
14042
14043 elt += oplen;
14044 for (i = 0; i < nargs; i += 1)
14045 elt = dump_subexp (exp, stream, elt);
14046
14047 return elt;
14048 }
14049
14050 /* The Ada extension of print_subexp (q.v.). */
14051
14052 static void
14053 ada_print_subexp (struct expression *exp, int *pos,
14054 struct ui_file *stream, enum precedence prec)
14055 {
14056 int oplen, nargs, i;
14057 int pc = *pos;
14058 enum exp_opcode op = exp->elts[pc].opcode;
14059
14060 ada_forward_operator_length (exp, pc, &oplen, &nargs);
14061
14062 *pos += oplen;
14063 switch (op)
14064 {
14065 default:
14066 *pos -= oplen;
14067 print_subexp_standard (exp, pos, stream, prec);
14068 return;
14069
14070 case OP_VAR_VALUE:
14071 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
14072 return;
14073
14074 case BINOP_IN_BOUNDS:
14075 /* XXX: sprint_subexp */
14076 print_subexp (exp, pos, stream, PREC_SUFFIX);
14077 fputs_filtered (" in ", stream);
14078 print_subexp (exp, pos, stream, PREC_SUFFIX);
14079 fputs_filtered ("'range", stream);
14080 if (exp->elts[pc + 1].longconst > 1)
14081 fprintf_filtered (stream, "(%ld)",
14082 (long) exp->elts[pc + 1].longconst);
14083 return;
14084
14085 case TERNOP_IN_RANGE:
14086 if (prec >= PREC_EQUAL)
14087 fputs_filtered ("(", stream);
14088 /* XXX: sprint_subexp */
14089 print_subexp (exp, pos, stream, PREC_SUFFIX);
14090 fputs_filtered (" in ", stream);
14091 print_subexp (exp, pos, stream, PREC_EQUAL);
14092 fputs_filtered (" .. ", stream);
14093 print_subexp (exp, pos, stream, PREC_EQUAL);
14094 if (prec >= PREC_EQUAL)
14095 fputs_filtered (")", stream);
14096 return;
14097
14098 case OP_ATR_FIRST:
14099 case OP_ATR_LAST:
14100 case OP_ATR_LENGTH:
14101 case OP_ATR_IMAGE:
14102 case OP_ATR_MAX:
14103 case OP_ATR_MIN:
14104 case OP_ATR_MODULUS:
14105 case OP_ATR_POS:
14106 case OP_ATR_SIZE:
14107 case OP_ATR_TAG:
14108 case OP_ATR_VAL:
14109 if (exp->elts[*pos].opcode == OP_TYPE)
14110 {
14111 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
14112 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
14113 &type_print_raw_options);
14114 *pos += 3;
14115 }
14116 else
14117 print_subexp (exp, pos, stream, PREC_SUFFIX);
14118 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
14119 if (nargs > 1)
14120 {
14121 int tem;
14122
14123 for (tem = 1; tem < nargs; tem += 1)
14124 {
14125 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
14126 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
14127 }
14128 fputs_filtered (")", stream);
14129 }
14130 return;
14131
14132 case UNOP_QUAL:
14133 type_print (exp->elts[pc + 1].type, "", stream, 0);
14134 fputs_filtered ("'(", stream);
14135 print_subexp (exp, pos, stream, PREC_PREFIX);
14136 fputs_filtered (")", stream);
14137 return;
14138
14139 case UNOP_IN_RANGE:
14140 /* XXX: sprint_subexp */
14141 print_subexp (exp, pos, stream, PREC_SUFFIX);
14142 fputs_filtered (" in ", stream);
14143 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
14144 &type_print_raw_options);
14145 return;
14146
14147 case OP_DISCRETE_RANGE:
14148 print_subexp (exp, pos, stream, PREC_SUFFIX);
14149 fputs_filtered ("..", stream);
14150 print_subexp (exp, pos, stream, PREC_SUFFIX);
14151 return;
14152
14153 case OP_OTHERS:
14154 fputs_filtered ("others => ", stream);
14155 print_subexp (exp, pos, stream, PREC_SUFFIX);
14156 return;
14157
14158 case OP_CHOICES:
14159 for (i = 0; i < nargs-1; i += 1)
14160 {
14161 if (i > 0)
14162 fputs_filtered ("|", stream);
14163 print_subexp (exp, pos, stream, PREC_SUFFIX);
14164 }
14165 fputs_filtered (" => ", stream);
14166 print_subexp (exp, pos, stream, PREC_SUFFIX);
14167 return;
14168
14169 case OP_POSITIONAL:
14170 print_subexp (exp, pos, stream, PREC_SUFFIX);
14171 return;
14172
14173 case OP_AGGREGATE:
14174 fputs_filtered ("(", stream);
14175 for (i = 0; i < nargs; i += 1)
14176 {
14177 if (i > 0)
14178 fputs_filtered (", ", stream);
14179 print_subexp (exp, pos, stream, PREC_SUFFIX);
14180 }
14181 fputs_filtered (")", stream);
14182 return;
14183 }
14184 }
14185
14186 /* Table mapping opcodes into strings for printing operators
14187 and precedences of the operators. */
14188
14189 static const struct op_print ada_op_print_tab[] = {
14190 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
14191 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
14192 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
14193 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
14194 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
14195 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
14196 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
14197 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
14198 {"<=", BINOP_LEQ, PREC_ORDER, 0},
14199 {">=", BINOP_GEQ, PREC_ORDER, 0},
14200 {">", BINOP_GTR, PREC_ORDER, 0},
14201 {"<", BINOP_LESS, PREC_ORDER, 0},
14202 {">>", BINOP_RSH, PREC_SHIFT, 0},
14203 {"<<", BINOP_LSH, PREC_SHIFT, 0},
14204 {"+", BINOP_ADD, PREC_ADD, 0},
14205 {"-", BINOP_SUB, PREC_ADD, 0},
14206 {"&", BINOP_CONCAT, PREC_ADD, 0},
14207 {"*", BINOP_MUL, PREC_MUL, 0},
14208 {"/", BINOP_DIV, PREC_MUL, 0},
14209 {"rem", BINOP_REM, PREC_MUL, 0},
14210 {"mod", BINOP_MOD, PREC_MUL, 0},
14211 {"**", BINOP_EXP, PREC_REPEAT, 0},
14212 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
14213 {"-", UNOP_NEG, PREC_PREFIX, 0},
14214 {"+", UNOP_PLUS, PREC_PREFIX, 0},
14215 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
14216 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
14217 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
14218 {".all", UNOP_IND, PREC_SUFFIX, 1},
14219 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
14220 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
14221 {NULL, OP_NULL, PREC_SUFFIX, 0}
14222 };
14223
14224 enum ada_primitive_types {
14225 ada_primitive_type_int,
14226 ada_primitive_type_long,
14227 ada_primitive_type_short,
14228 ada_primitive_type_char,
14229 ada_primitive_type_float,
14230 ada_primitive_type_double,
14231 ada_primitive_type_void,
14232 ada_primitive_type_long_long,
14233 ada_primitive_type_long_double,
14234 ada_primitive_type_natural,
14235 ada_primitive_type_positive,
14236 ada_primitive_type_system_address,
14237 ada_primitive_type_storage_offset,
14238 nr_ada_primitive_types
14239 };
14240
14241 static void
14242 ada_language_arch_info (struct gdbarch *gdbarch,
14243 struct language_arch_info *lai)
14244 {
14245 const struct builtin_type *builtin = builtin_type (gdbarch);
14246
14247 lai->primitive_type_vector
14248 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_ada_primitive_types + 1,
14249 struct type *);
14250
14251 lai->primitive_type_vector [ada_primitive_type_int]
14252 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14253 0, "integer");
14254 lai->primitive_type_vector [ada_primitive_type_long]
14255 = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
14256 0, "long_integer");
14257 lai->primitive_type_vector [ada_primitive_type_short]
14258 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
14259 0, "short_integer");
14260 lai->string_char_type
14261 = lai->primitive_type_vector [ada_primitive_type_char]
14262 = arch_character_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
14263 lai->primitive_type_vector [ada_primitive_type_float]
14264 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
14265 "float", gdbarch_float_format (gdbarch));
14266 lai->primitive_type_vector [ada_primitive_type_double]
14267 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
14268 "long_float", gdbarch_double_format (gdbarch));
14269 lai->primitive_type_vector [ada_primitive_type_long_long]
14270 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
14271 0, "long_long_integer");
14272 lai->primitive_type_vector [ada_primitive_type_long_double]
14273 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
14274 "long_long_float", gdbarch_long_double_format (gdbarch));
14275 lai->primitive_type_vector [ada_primitive_type_natural]
14276 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14277 0, "natural");
14278 lai->primitive_type_vector [ada_primitive_type_positive]
14279 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
14280 0, "positive");
14281 lai->primitive_type_vector [ada_primitive_type_void]
14282 = builtin->builtin_void;
14283
14284 lai->primitive_type_vector [ada_primitive_type_system_address]
14285 = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT,
14286 "void"));
14287 TYPE_NAME (lai->primitive_type_vector [ada_primitive_type_system_address])
14288 = "system__address";
14289
14290 /* Create the equivalent of the System.Storage_Elements.Storage_Offset
14291 type. This is a signed integral type whose size is the same as
14292 the size of addresses. */
14293 {
14294 unsigned int addr_length = TYPE_LENGTH
14295 (lai->primitive_type_vector [ada_primitive_type_system_address]);
14296
14297 lai->primitive_type_vector [ada_primitive_type_storage_offset]
14298 = arch_integer_type (gdbarch, addr_length * HOST_CHAR_BIT, 0,
14299 "storage_offset");
14300 }
14301
14302 lai->bool_type_symbol = NULL;
14303 lai->bool_type_default = builtin->builtin_bool;
14304 }
14305
14306 /* Language vector */
14307
14308 /* Not really used, but needed in the ada_language_defn. */
14309
14310 static void
14311 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
14312 {
14313 ada_emit_char (c, type, stream, quoter, 1);
14314 }
14315
14316 static int
14317 parse (struct parser_state *ps)
14318 {
14319 warnings_issued = 0;
14320 return ada_parse (ps);
14321 }
14322
14323 static const struct exp_descriptor ada_exp_descriptor = {
14324 ada_print_subexp,
14325 ada_operator_length,
14326 ada_operator_check,
14327 ada_op_name,
14328 ada_dump_subexp_body,
14329 ada_evaluate_subexp
14330 };
14331
14332 /* symbol_name_matcher_ftype adapter for wild_match. */
14333
14334 static bool
14335 do_wild_match (const char *symbol_search_name,
14336 const lookup_name_info &lookup_name,
14337 completion_match_result *comp_match_res)
14338 {
14339 return wild_match (symbol_search_name, ada_lookup_name (lookup_name));
14340 }
14341
14342 /* symbol_name_matcher_ftype adapter for full_match. */
14343
14344 static bool
14345 do_full_match (const char *symbol_search_name,
14346 const lookup_name_info &lookup_name,
14347 completion_match_result *comp_match_res)
14348 {
14349 return full_match (symbol_search_name, ada_lookup_name (lookup_name));
14350 }
14351
14352 /* Build the Ada lookup name for LOOKUP_NAME. */
14353
14354 ada_lookup_name_info::ada_lookup_name_info (const lookup_name_info &lookup_name)
14355 {
14356 const std::string &user_name = lookup_name.name ();
14357
14358 if (user_name[0] == '<')
14359 {
14360 if (user_name.back () == '>')
14361 m_encoded_name = user_name.substr (1, user_name.size () - 2);
14362 else
14363 m_encoded_name = user_name.substr (1, user_name.size () - 1);
14364 m_encoded_p = true;
14365 m_verbatim_p = true;
14366 m_wild_match_p = false;
14367 m_standard_p = false;
14368 }
14369 else
14370 {
14371 m_verbatim_p = false;
14372
14373 m_encoded_p = user_name.find ("__") != std::string::npos;
14374
14375 if (!m_encoded_p)
14376 {
14377 const char *folded = ada_fold_name (user_name.c_str ());
14378 const char *encoded = ada_encode_1 (folded, false);
14379 if (encoded != NULL)
14380 m_encoded_name = encoded;
14381 else
14382 m_encoded_name = user_name;
14383 }
14384 else
14385 m_encoded_name = user_name;
14386
14387 /* Handle the 'package Standard' special case. See description
14388 of m_standard_p. */
14389 if (startswith (m_encoded_name.c_str (), "standard__"))
14390 {
14391 m_encoded_name = m_encoded_name.substr (sizeof ("standard__") - 1);
14392 m_standard_p = true;
14393 }
14394 else
14395 m_standard_p = false;
14396
14397 /* If the name contains a ".", then the user is entering a fully
14398 qualified entity name, and the match must not be done in wild
14399 mode. Similarly, if the user wants to complete what looks
14400 like an encoded name, the match must not be done in wild
14401 mode. Also, in the standard__ special case always do
14402 non-wild matching. */
14403 m_wild_match_p
14404 = (lookup_name.match_type () != symbol_name_match_type::FULL
14405 && !m_encoded_p
14406 && !m_standard_p
14407 && user_name.find ('.') == std::string::npos);
14408 }
14409 }
14410
14411 /* symbol_name_matcher_ftype method for Ada. This only handles
14412 completion mode. */
14413
14414 static bool
14415 ada_symbol_name_matches (const char *symbol_search_name,
14416 const lookup_name_info &lookup_name,
14417 completion_match_result *comp_match_res)
14418 {
14419 return lookup_name.ada ().matches (symbol_search_name,
14420 lookup_name.match_type (),
14421 comp_match_res);
14422 }
14423
14424 /* A name matcher that matches the symbol name exactly, with
14425 strcmp. */
14426
14427 static bool
14428 literal_symbol_name_matcher (const char *symbol_search_name,
14429 const lookup_name_info &lookup_name,
14430 completion_match_result *comp_match_res)
14431 {
14432 const std::string &name = lookup_name.name ();
14433
14434 int cmp = (lookup_name.completion_mode ()
14435 ? strncmp (symbol_search_name, name.c_str (), name.size ())
14436 : strcmp (symbol_search_name, name.c_str ()));
14437 if (cmp == 0)
14438 {
14439 if (comp_match_res != NULL)
14440 comp_match_res->set_match (symbol_search_name);
14441 return true;
14442 }
14443 else
14444 return false;
14445 }
14446
14447 /* Implement the "la_get_symbol_name_matcher" language_defn method for
14448 Ada. */
14449
14450 static symbol_name_matcher_ftype *
14451 ada_get_symbol_name_matcher (const lookup_name_info &lookup_name)
14452 {
14453 if (lookup_name.match_type () == symbol_name_match_type::SEARCH_NAME)
14454 return literal_symbol_name_matcher;
14455
14456 if (lookup_name.completion_mode ())
14457 return ada_symbol_name_matches;
14458 else
14459 {
14460 if (lookup_name.ada ().wild_match_p ())
14461 return do_wild_match;
14462 else
14463 return do_full_match;
14464 }
14465 }
14466
14467 /* Implement the "la_read_var_value" language_defn method for Ada. */
14468
14469 static struct value *
14470 ada_read_var_value (struct symbol *var, const struct block *var_block,
14471 struct frame_info *frame)
14472 {
14473 const struct block *frame_block = NULL;
14474 struct symbol *renaming_sym = NULL;
14475
14476 /* The only case where default_read_var_value is not sufficient
14477 is when VAR is a renaming... */
14478 if (frame)
14479 frame_block = get_frame_block (frame, NULL);
14480 if (frame_block)
14481 renaming_sym = ada_find_renaming_symbol (var, frame_block);
14482 if (renaming_sym != NULL)
14483 return ada_read_renaming_var_value (renaming_sym, frame_block);
14484
14485 /* This is a typical case where we expect the default_read_var_value
14486 function to work. */
14487 return default_read_var_value (var, var_block, frame);
14488 }
14489
14490 static const char *ada_extensions[] =
14491 {
14492 ".adb", ".ads", ".a", ".ada", ".dg", NULL
14493 };
14494
14495 extern const struct language_defn ada_language_defn = {
14496 "ada", /* Language name */
14497 "Ada",
14498 language_ada,
14499 range_check_off,
14500 case_sensitive_on, /* Yes, Ada is case-insensitive, but
14501 that's not quite what this means. */
14502 array_row_major,
14503 macro_expansion_no,
14504 ada_extensions,
14505 &ada_exp_descriptor,
14506 parse,
14507 ada_yyerror,
14508 resolve,
14509 ada_printchar, /* Print a character constant */
14510 ada_printstr, /* Function to print string constant */
14511 emit_char, /* Function to print single char (not used) */
14512 ada_print_type, /* Print a type using appropriate syntax */
14513 ada_print_typedef, /* Print a typedef using appropriate syntax */
14514 ada_val_print, /* Print a value using appropriate syntax */
14515 ada_value_print, /* Print a top-level value */
14516 ada_read_var_value, /* la_read_var_value */
14517 NULL, /* Language specific skip_trampoline */
14518 NULL, /* name_of_this */
14519 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
14520 basic_lookup_transparent_type, /* lookup_transparent_type */
14521 ada_la_decode, /* Language specific symbol demangler */
14522 ada_sniff_from_mangled_name,
14523 NULL, /* Language specific
14524 class_name_from_physname */
14525 ada_op_print_tab, /* expression operators for printing */
14526 0, /* c-style arrays */
14527 1, /* String lower bound */
14528 ada_get_gdb_completer_word_break_characters,
14529 ada_collect_symbol_completion_matches,
14530 ada_language_arch_info,
14531 ada_print_array_index,
14532 default_pass_by_reference,
14533 c_get_string,
14534 c_watch_location_expression,
14535 ada_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
14536 ada_iterate_over_symbols,
14537 default_search_name_hash,
14538 &ada_varobj_ops,
14539 NULL,
14540 NULL,
14541 LANG_MAGIC
14542 };
14543
14544 /* Command-list for the "set/show ada" prefix command. */
14545 static struct cmd_list_element *set_ada_list;
14546 static struct cmd_list_element *show_ada_list;
14547
14548 /* Implement the "set ada" prefix command. */
14549
14550 static void
14551 set_ada_command (const char *arg, int from_tty)
14552 {
14553 printf_unfiltered (_(\
14554 "\"set ada\" must be followed by the name of a setting.\n"));
14555 help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
14556 }
14557
14558 /* Implement the "show ada" prefix command. */
14559
14560 static void
14561 show_ada_command (const char *args, int from_tty)
14562 {
14563 cmd_show_list (show_ada_list, from_tty, "");
14564 }
14565
14566 static void
14567 initialize_ada_catchpoint_ops (void)
14568 {
14569 struct breakpoint_ops *ops;
14570
14571 initialize_breakpoint_ops ();
14572
14573 ops = &catch_exception_breakpoint_ops;
14574 *ops = bkpt_breakpoint_ops;
14575 ops->allocate_location = allocate_location_catch_exception;
14576 ops->re_set = re_set_catch_exception;
14577 ops->check_status = check_status_catch_exception;
14578 ops->print_it = print_it_catch_exception;
14579 ops->print_one = print_one_catch_exception;
14580 ops->print_mention = print_mention_catch_exception;
14581 ops->print_recreate = print_recreate_catch_exception;
14582
14583 ops = &catch_exception_unhandled_breakpoint_ops;
14584 *ops = bkpt_breakpoint_ops;
14585 ops->allocate_location = allocate_location_catch_exception_unhandled;
14586 ops->re_set = re_set_catch_exception_unhandled;
14587 ops->check_status = check_status_catch_exception_unhandled;
14588 ops->print_it = print_it_catch_exception_unhandled;
14589 ops->print_one = print_one_catch_exception_unhandled;
14590 ops->print_mention = print_mention_catch_exception_unhandled;
14591 ops->print_recreate = print_recreate_catch_exception_unhandled;
14592
14593 ops = &catch_assert_breakpoint_ops;
14594 *ops = bkpt_breakpoint_ops;
14595 ops->allocate_location = allocate_location_catch_assert;
14596 ops->re_set = re_set_catch_assert;
14597 ops->check_status = check_status_catch_assert;
14598 ops->print_it = print_it_catch_assert;
14599 ops->print_one = print_one_catch_assert;
14600 ops->print_mention = print_mention_catch_assert;
14601 ops->print_recreate = print_recreate_catch_assert;
14602
14603 ops = &catch_handlers_breakpoint_ops;
14604 *ops = bkpt_breakpoint_ops;
14605 ops->allocate_location = allocate_location_catch_handlers;
14606 ops->re_set = re_set_catch_handlers;
14607 ops->check_status = check_status_catch_handlers;
14608 ops->print_it = print_it_catch_handlers;
14609 ops->print_one = print_one_catch_handlers;
14610 ops->print_mention = print_mention_catch_handlers;
14611 ops->print_recreate = print_recreate_catch_handlers;
14612 }
14613
14614 /* This module's 'new_objfile' observer. */
14615
14616 static void
14617 ada_new_objfile_observer (struct objfile *objfile)
14618 {
14619 ada_clear_symbol_cache ();
14620 }
14621
14622 /* This module's 'free_objfile' observer. */
14623
14624 static void
14625 ada_free_objfile_observer (struct objfile *objfile)
14626 {
14627 ada_clear_symbol_cache ();
14628 }
14629
14630 void
14631 _initialize_ada_language (void)
14632 {
14633 initialize_ada_catchpoint_ops ();
14634
14635 add_prefix_cmd ("ada", no_class, set_ada_command,
14636 _("Prefix command for changing Ada-specfic settings"),
14637 &set_ada_list, "set ada ", 0, &setlist);
14638
14639 add_prefix_cmd ("ada", no_class, show_ada_command,
14640 _("Generic command for showing Ada-specific settings."),
14641 &show_ada_list, "show ada ", 0, &showlist);
14642
14643 add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
14644 &trust_pad_over_xvs, _("\
14645 Enable or disable an optimization trusting PAD types over XVS types"), _("\
14646 Show whether an optimization trusting PAD types over XVS types is activated"),
14647 _("\
14648 This is related to the encoding used by the GNAT compiler. The debugger\n\
14649 should normally trust the contents of PAD types, but certain older versions\n\
14650 of GNAT have a bug that sometimes causes the information in the PAD type\n\
14651 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
14652 work around this bug. It is always safe to turn this option \"off\", but\n\
14653 this incurs a slight performance penalty, so it is recommended to NOT change\n\
14654 this option to \"off\" unless necessary."),
14655 NULL, NULL, &set_ada_list, &show_ada_list);
14656
14657 add_setshow_boolean_cmd ("print-signatures", class_vars,
14658 &print_signatures, _("\
14659 Enable or disable the output of formal and return types for functions in the \
14660 overloads selection menu"), _("\
14661 Show whether the output of formal and return types for functions in the \
14662 overloads selection menu is activated"),
14663 NULL, NULL, NULL, &set_ada_list, &show_ada_list);
14664
14665 add_catch_command ("exception", _("\
14666 Catch Ada exceptions, when raised.\n\
14667 With an argument, catch only exceptions with the given name."),
14668 catch_ada_exception_command,
14669 NULL,
14670 CATCH_PERMANENT,
14671 CATCH_TEMPORARY);
14672
14673 add_catch_command ("handlers", _("\
14674 Catch Ada exceptions, when handled.\n\
14675 With an argument, catch only exceptions with the given name."),
14676 catch_ada_handlers_command,
14677 NULL,
14678 CATCH_PERMANENT,
14679 CATCH_TEMPORARY);
14680 add_catch_command ("assert", _("\
14681 Catch failed Ada assertions, when raised.\n\
14682 With an argument, catch only exceptions with the given name."),
14683 catch_assert_command,
14684 NULL,
14685 CATCH_PERMANENT,
14686 CATCH_TEMPORARY);
14687
14688 varsize_limit = 65536;
14689
14690 add_info ("exceptions", info_exceptions_command,
14691 _("\
14692 List all Ada exception names.\n\
14693 If a regular expression is passed as an argument, only those matching\n\
14694 the regular expression are listed."));
14695
14696 add_prefix_cmd ("ada", class_maintenance, maint_set_ada_cmd,
14697 _("Set Ada maintenance-related variables."),
14698 &maint_set_ada_cmdlist, "maintenance set ada ",
14699 0/*allow-unknown*/, &maintenance_set_cmdlist);
14700
14701 add_prefix_cmd ("ada", class_maintenance, maint_show_ada_cmd,
14702 _("Show Ada maintenance-related variables"),
14703 &maint_show_ada_cmdlist, "maintenance show ada ",
14704 0/*allow-unknown*/, &maintenance_show_cmdlist);
14705
14706 add_setshow_boolean_cmd
14707 ("ignore-descriptive-types", class_maintenance,
14708 &ada_ignore_descriptive_types_p,
14709 _("Set whether descriptive types generated by GNAT should be ignored."),
14710 _("Show whether descriptive types generated by GNAT should be ignored."),
14711 _("\
14712 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
14713 DWARF attribute."),
14714 NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
14715
14716 decoded_names_store = htab_create_alloc
14717 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
14718 NULL, xcalloc, xfree);
14719
14720 /* The ada-lang observers. */
14721 observer_attach_new_objfile (ada_new_objfile_observer);
14722 observer_attach_free_objfile (ada_free_objfile_observer);
14723 observer_attach_inferior_exit (ada_inferior_exit);
14724
14725 /* Setup various context-specific data. */
14726 ada_inferior_data
14727 = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
14728 ada_pspace_data_handle
14729 = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
14730 }
ada_emit_char
void ada_emit_char(int, struct type *, struct ui_file *, int, int)
Definition: ada-valprint.c:259
ada_is_redundant_range_encoding
static int ada_is_redundant_range_encoding(struct type *range_type, struct type *encoding_type)
Definition: ada-lang.c:8843
error_no_arg
void error_no_arg(const char *why)
Definition: cli-cmds.c:185
target_gdbarch
struct gdbarch * target_gdbarch(void)
Definition: gdbarch.c:5467
is_valid_name_for_wild_match
static int is_valid_name_for_wild_match(const char *name0)
Definition: ada-lang.c:6151
gdbarch
Definition: gdbarch.c:127
string
const char * string
Definition: signals.c:50
value_zero
struct value * value_zero(struct type *type, enum lval_type lv)
Definition: valops.c:847
mi-common.h
template_to_fixed_record_type
static struct type * template_to_fixed_record_type(struct type *type, const gdb_byte *valaddr, CORE_ADDR address, struct value *dval0)
Definition: ada-lang.c:8597
lookup_name_info::ada
const ada_lookup_name_info & ada() const
Definition: symtab.h:240
ada_remove_trailing_digits
static void ada_remove_trailing_digits(const char *encoded, int *len)
Definition: ada-lang.c:1096
expression::elts
union exp_element elts[1]
Definition: expression.h:84
ada_is_character_type
int ada_is_character_type(struct type *type)
Definition: ada-lang.c:9463
TYPE_CODE_BOOL
Definition: gdbtypes.h:164
value_mark
struct value * value_mark(void)
Definition: value.c:1589
desc_bound_bitpos
static int desc_bound_bitpos(struct type *, int, int)
Definition: ada-lang.c:1852
PRINT_SRC_AND_LOC
Definition: breakpoint.h:505
should_stop_exception
static int should_stop_exception(const struct bp_location *bl)
Definition: ada-lang.c:12613
breakpoint::loc
bp_location * loc
Definition: breakpoint.h:702
symtab_to_filename_for_display
const char * symtab_to_filename_for_display(struct symtab *symtab)
Definition: source.c:1168
type_code
type_code
Definition: gdbtypes.h:80
PREC_ADD
Definition: parser-defs.h:298
TYPE_CODE_ARRAY
Definition: gdbtypes.h:104
ada_get_decoded_value
struct value * ada_get_decoded_value(struct value *value)
Definition: ada-lang.c:861
breakpoint_ops::print_recreate
void(* print_recreate)(struct breakpoint *, struct ui_file *fp)
Definition: breakpoint.h:593
print_mention_catch_exception_unhandled
static void print_mention_catch_exception_unhandled(struct breakpoint *b)
Definition: ada-lang.c:12984
completer.h
ada_operator_length
static void ada_operator_length(const struct expression *exp, int pc, int *oplenp, int *argsp)
Definition: ada-lang.c:13862
DYN_PROP_BYTE_STRIDE
Definition: gdbtypes.h:433
exp_descriptor
Definition: parser-defs.h:320
language_lookup_primitive_type_as_symbol
struct symbol * language_lookup_primitive_type_as_symbol(const struct language_defn *la, struct gdbarch *gdbarch, const char *name)
Definition: language.c:1099
ada_lookup_symbol_list_worker
static int ada_lookup_symbol_list_worker(const lookup_name_info &lookup_name, const struct block *block, domain_enum domain, struct block_symbol **results, int full_search)
Definition: ada-lang.c:5827
ada_args_match
static int ada_args_match(struct symbol *, struct value **, int)
Definition: ada-lang.c:3688
ada_add_all_symbols
static void ada_add_all_symbols(struct obstack *, const struct block *, const lookup_name_info &lookup_name, domain_enum, int, int *)
Definition: ada-lang.c:5744
ada_value_slice
static struct value * ada_value_slice(struct value *array, int low, int high)
Definition: ada-lang.c:2937
ada_primitive_type_float
Definition: ada-lang.c:14229
arch_type
struct type * arch_type(struct gdbarch *gdbarch, enum type_code code, int bit, const char *name)
Definition: gdbtypes.c:4941
gdb_obstack.h
value_addr
struct value * value_addr(struct value *arg1)
Definition: valops.c:1462
gdbarch_double_format
const struct floatformat ** gdbarch_double_format(struct gdbarch *gdbarch)
Definition: gdbarch.c:1730
ada_get_field_index
int ada_get_field_index(const struct type *type, const char *field_name, int maybe_missing)
Definition: ada-lang.c:619
using_direct::import_dest
const char * import_dest
Definition: namespace.h:93
TYPE_CODE_ENUM
Definition: gdbtypes.h:108
copy_type
struct type * copy_type(const struct type *type)
Definition: gdbtypes.c:4916
get_selected_frame
struct frame_info * get_selected_frame(const char *message)
Definition: frame.c:1638
ada_is_bogus_array_descriptor
int ada_is_bogus_array_descriptor(struct type *type)
Definition: ada-lang.c:1961
ada_has_this_exception_support
static int ada_has_this_exception_support(const struct exception_support_info *einfo)
Definition: ada-lang.c:12087
get_cmd_context
void * get_cmd_context(struct cmd_list_element *cmd)
Definition: cli-decode.c:148
old_renaming_is_invisible
static int old_renaming_is_invisible(const struct symbol *sym, const char *function_name)
Definition: ada-lang.c:5260
create_static_range_type
struct type * create_static_range_type(struct type *result_type, struct type *index_type, LONGEST low_bound, LONGEST high_bound)
Definition: gdbtypes.c:945
range_check_off
Definition: language.h:61
observer_attach_free_objfile
struct observer * observer_attach_free_objfile(observer_free_objfile_ftype *f)
builtin_type::builtin_long_double
struct type * builtin_long_double
Definition: gdbtypes.h:1512
using_direct::alias
const char * alias
Definition: namespace.h:95
ui_out::field_core_addr
void field_core_addr(const char *fldname, struct gdbarch *gdbarch, CORE_ADDR address)
Definition: ui-out.c:513
SYMBOL_PRINT_NAME
#define SYMBOL_PRINT_NAME(symbol)
Definition: symtab.h:542
print_one_catch_exception_unhandled
static void print_one_catch_exception_unhandled(struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:12977
PREC_PREFIX
Definition: parser-defs.h:299
advance_wild_match
static int advance_wild_match(const char **, const char *, int)
Definition: ada-lang.c:6174
ada_parent_type
struct type * ada_parent_type(struct type *type)
Definition: ada-lang.c:6955
exp_element::opcode
enum exp_opcode opcode
Definition: expression.h:64
value_subscript
struct value * value_subscript(struct value *array, LONGEST index)
Definition: valarith.c:142
standard_exc
static const char * standard_exc[]
Definition: ada-lang.c:12013
ada_tag_name
const char * ada_tag_name(struct value *tag)
Definition: ada-lang.c:6921
MSYMBOL_LINKAGE_NAME
#define MSYMBOL_LINKAGE_NAME(symbol)
Definition: symtab.h:707
infcall.h
MSYMBOL_LANGUAGE
#define MSYMBOL_LANGUAGE(symbol)
Definition: symtab.h:698
PREC_EQUAL
Definition: parser-defs.h:298
get_current_frame
struct frame_info * get_current_frame(void)
Definition: frame.c:1563
value_from_contents_and_address
struct value * value_from_contents_and_address(struct type *type, const gdb_byte *valaddr, CORE_ADDR address)
Definition: value.c:3599
field_name_match
static int field_name_match(const char *field_name, const char *target)
Definition: ada-lang.c:597
ui_out::field_string
void field_string(const char *fldname, const char *string)
Definition: ui-out.c:544
CORE_ADDR
bfd_vma CORE_ADDR
Definition: common-types.h:41
noside
noside
Definition: expression.h:123
read_memory_string
void read_memory_string(CORE_ADDR memaddr, char *buffer, int max_len)
Definition: corefile.c:356
ada_exp_descriptor
static const struct exp_descriptor ada_exp_descriptor
Definition: ada-lang.c:14323
TYPE_FIELD_NAME
#define TYPE_FIELD_NAME(thistype, n)
Definition: gdbtypes.h:1372
value_val_atr
static struct value * value_val_atr(struct type *, struct value *)
Definition: ada-lang.c:9436
RETURN_MASK_ALL
Definition: common-exceptions.h:44
cond_offset_host
static const gdb_byte * cond_offset_host(const gdb_byte *valaddr, long offset)
Definition: ada-lang.c:703
ada_print_array_index
static void ada_print_array_index(struct value *index_value, struct ui_file *stream, const struct value_print_options *options)
Definition: ada-lang.c:569
thin_descriptor_type
static struct type * thin_descriptor_type(struct type *type)
Definition: ada-lang.c:1617
using_direct::import_src
const char * import_src
Definition: namespace.h:92
default_search_name_hash
unsigned int default_search_name_hash(const char *string0)
Definition: dictionary.c:769
ada_varobj_ops
const struct lang_varobj_ops ada_varobj_ops
Definition: ada-varobj.c:995
ptid_get_pid
int ptid_get_pid(const ptid_t &ptid)
Definition: ptid.c:47
expression_up
gdb::unique_xmalloc_ptr< expression > expression_up
Definition: expression.h:87
arm-linux.m
m
Definition: arm-linux.py:44
multiple_symbols_cancel
const char multiple_symbols_cancel[]
Definition: symtab.c:239
ada_encode
char * ada_encode(const char *decoded)
Definition: ada-lang.c:1041
do_full_match
static bool do_full_match(const char *symbol_search_name, const lookup_name_info &lookup_name, completion_match_result *comp_match_res)
Definition: ada-lang.c:14345
xfree
void xfree(void *)
ada_is_others_clause
int ada_is_others_clause(struct type *type, int field_num)
Definition: ada-lang.c:7057
ada_value_primitive_packed_val
struct value * ada_value_primitive_packed_val(struct value *obj, const gdb_byte *valaddr, long offset, int bit_offset, int bit_size, struct type *type)
Definition: ada-lang.c:2553
HAVE_GNAT_AUX_INFO
#define HAVE_GNAT_AUX_INFO(type)
Definition: gdbtypes.h:1213
LOC_BLOCK
Definition: symtab.h:854
TYPE_LOW_BOUND
#define TYPE_LOW_BOUND(range_type)
Definition: gdbtypes.h:1244
ada_lookup_name_info::wild_match_p
bool wild_match_p() const
Definition: symtab.h:105
no_class
Definition: command.h:41
match_data::obstackp
struct obstack * obstackp
Definition: ada-lang.c:5465
EVAL_NORMAL
Definition: expression.h:125
GDBARCH_OBSTACK_CALLOC
#define GDBARCH_OBSTACK_CALLOC(GDBARCH, NR, TYPE)
Definition: gdbarch.h:1708
ada_add_exceptions_from_frame
static void ada_add_exceptions_from_frame(compiled_regex *preg, struct frame_info *frame, std::vector< ada_exc_info > *exceptions)
Definition: ada-lang.c:13645
get_prev_frame
struct frame_info * get_prev_frame(struct frame_info *this_frame)
Definition: frame.c:2254
function-view.h
disp_del
Definition: breakpoint.h:219
parse
static int parse(struct parser_state *ps)
Definition: ada-lang.c:14317
command_line_input
char * command_line_input(const char *, int, const char *)
Definition: top.c:1173
TYPE_OBJFILE
#define TYPE_OBJFILE(t)
Definition: gdbtypes.h:291
value_as_long
LONGEST value_as_long(struct value *val)
Definition: value.c:2749
cmd_list_element
Definition: cli-decode.h:46
gdbarch_int_bit
int gdbarch_int_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1579
func
void(* func)(char *)
Definition: remote-fileio.c:1104
allocate_location_catch_handlers
static struct bp_location * allocate_location_catch_handlers(struct breakpoint *self)
Definition: ada-lang.c:13047
gdb_regex.h
INT_MAX
#define INT_MAX
Definition: defs.h:477
BMSYMBOL_VALUE_ADDRESS
#define BMSYMBOL_VALUE_ADDRESS(symbol)
Definition: symtab.h:691
func_type
Definition: gdbtypes.h:1059
parse_completion
int parse_completion
Definition: parse.c:80
warning
void warning(const char *fmt,...)
Definition: errors.c:26
CATCH_TEMPORARY
#define CATCH_TEMPORARY
Definition: breakpoint.h:1283
name_match_type_from_name
static symbol_name_match_type name_match_type_from_name(const char *lookup_name)
Definition: ada-lang.c:4776
evaluate_var_value
value * evaluate_var_value(enum noside noside, const block *blk, symbol *var)
Definition: eval.c:709
catch_exception_unhandled_breakpoint_ops
static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
Definition: ada-lang.c:12996
expand_symtabs_matching
void expand_symtabs_matching(gdb::function_view< expand_symtabs_file_matcher_ftype > file_matcher, const lookup_name_info &lookup_name, gdb::function_view< expand_symtabs_symbol_matcher_ftype > symbol_matcher, gdb::function_view< expand_symtabs_exp_notify_ftype > expansion_notify, enum search_domain kind)
Definition: symfile.c:3803
ada_search_struct_field
static struct value * ada_search_struct_field(const char *, struct value *, int, struct type *)
Definition: ada-lang.c:7427
catch_ada_exception_command
static void catch_ada_exception_command(const char *arg_entry, int from_tty, struct cmd_list_element *command)
Definition: ada-lang.c:13422
evaluate_subexp_with_coercion
struct value * evaluate_subexp_with_coercion(struct expression *exp, int *pos, enum noside noside)
Definition: eval.c:3048
create_array_type
struct type * create_array_type(struct type *result_type, struct type *element_type, struct type *range_type)
Definition: gdbtypes.c:1223
symbol_search_name
const char * symbol_search_name(const struct general_symbol_info *gsymbol)
Definition: symtab.c:943
ada_catch_handlers
Definition: ada-lang.h:112
ada_primitive_type_system_address
Definition: ada-lang.c:14236
ada_exc_info::name
const char * name
Definition: ada-lang.h:390
TYPE_NAME
#define TYPE_NAME(thistype)
Definition: gdbtypes.h:1224
ada_exc_info::operator==
bool operator==(const ada_exc_info &) const
Definition: ada-lang.c:13580
value_bitsize
LONGEST value_bitsize(const struct value *value)
Definition: value.c:1128
sort_choices
static void sort_choices(struct block_symbol syms[], int nsyms)
Definition: ada-lang.c:3848
ada_fold_name
char * ada_fold_name(const char *name)
Definition: ada-lang.c:1051
breakpoint_ops::print_it
enum print_stop_action(* print_it)(struct bpstats *bs)
Definition: breakpoint.h:568
match_data::objfile
struct objfile * objfile
Definition: ada-lang.c:5464
PREC_ORDER
Definition: parser-defs.h:298
INIT_CPLUS_SPECIFIC
#define INIT_CPLUS_SPECIFIC(type)
Definition: gdbtypes.h:1192
ada_to_fixed_type
struct type * ada_to_fixed_type(struct type *type, const gdb_byte *valaddr, CORE_ADDR address, struct value *dval, int check_tag)
Definition: ada-lang.c:9201
ada-lang.h
deprecated_value_modifiable
int deprecated_value_modifiable(const struct value *value)
Definition: value.c:1580
value_enclosing_type
struct type * value_enclosing_type(const struct value *value)
Definition: value.c:1175
value_at
struct value * value_at(struct type *type, CORE_ADDR addr)
Definition: valops.c:933
ada_in_variant
int ada_in_variant(LONGEST val, struct type *type, int field_num)
Definition: ada-lang.c:7165
gdbarch_long_double_format
const struct floatformat ** gdbarch_long_double_format(struct gdbarch *gdbarch)
Definition: gdbarch.c:1763
print_recreate_catch_handlers
static void print_recreate_catch_handlers(struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:13084
TYPE_HIGH_BOUND
#define TYPE_HIGH_BOUND(range_type)
Definition: gdbtypes.h:1246
install_breakpoint
void install_breakpoint(int internal, std::unique_ptr< breakpoint > &&arg, int update_gll)
Definition: breakpoint.c:8256
ada_catchpoint::~ada_catchpoint
~ada_catchpoint() override
Definition: ada-lang.c:12576
ada_print_symbol_signature
static void ada_print_symbol_signature(struct ui_file *stream, struct symbol *sym, const struct type_print_options *flags)
Definition: ada-lang.c:3878
lookup_name_info::completion_mode
bool completion_mode() const
Definition: symtab.h:195
complete_symbol_mode
complete_symbol_mode
Definition: symtab.h:1826
annotate_field
void annotate_field(int num)
Definition: annotate.c:177
ada_primitive_type_long_long
Definition: ada-lang.c:14232
domain_enum
enum domain_enum_tag domain_enum
TYPE_CODE_RANGE
Definition: gdbtypes.h:127
arch_character_type
struct type * arch_character_type(struct gdbarch *gdbarch, int bit, int unsigned_p, const char *name)
Definition: gdbtypes.c:4979
num_visible_fields
static int num_visible_fields(struct type *type)
Definition: ada-lang.c:7408
re_set_catch_handlers
static void re_set_catch_handlers(struct breakpoint *b)
Definition: ada-lang.c:13053
type_print_raw_options
const struct type_print_options type_print_raw_options
Definition: typeprint.c:40
builtin_type
const struct builtin_type * builtin_type(struct gdbarch *gdbarch)
Definition: gdbtypes.c:5217
user_select_syms
int user_select_syms(struct block_symbol *syms, int nsyms, int max_results)
Definition: ada-lang.c:3920
ada_pspace_data
Definition: ada-lang.c:443
add_info
struct cmd_list_element * add_info(const char *name, cmd_const_cfunc_ftype *fun, const char *doc)
Definition: cli-decode.c:886
empty_record
static struct type * empty_record(struct type *templ)
Definition: ada-lang.c:8318
warnings_issued
static int warnings_issued
Definition: ada-lang.c:338
RETURN_MASK_ERROR
Definition: common-exceptions.h:43
breakpoint::number
int number
Definition: breakpoint.h:699
ada_primitive_types
ada_primitive_types
Definition: ada-lang.c:14224
match_data
Definition: ada-lang.c:5462
allocate_value_lazy
struct value * allocate_value_lazy(struct type *type)
Definition: value.c:916
ada_primitive_type_short
Definition: ada-lang.c:14227
TYPE_CODE_INT
Definition: gdbtypes.h:111
select_frame
void select_frame(struct frame_info *fi)
Definition: frame.c:1677
ada_variant_discrim_type
struct type * ada_variant_discrim_type(struct type *var_type, struct type *outer_type)
Definition: ada-lang.c:7045
value_pos_atr
static struct value * value_pos_atr(struct type *, struct value *)
Definition: ada-lang.c:9428
SYMBOL_CLASS
#define SYMBOL_CLASS(symbol)
Definition: symtab.h:1155
memset
void * memset(T *s, int c, size_t n)=delete
check_status_catch_exception_unhandled
static void check_status_catch_exception_unhandled(bpstat bs)
Definition: ada-lang.c:12965
internal_error
void internal_error(const char *file, int line, const char *fmt,...)
Definition: errors.c:50
binop_promote
void binop_promote(const struct language_defn *language, struct gdbarch *gdbarch, struct value **arg1, struct value **arg2)
Definition: eval.c:452
HASH_SIZE
#define HASH_SIZE
Definition: ada-lang.c:306
desc_one_bound
static struct value * desc_one_bound(struct value *, int, int)
Definition: ada-lang.c:1841
PREC_BITWISE_XOR
Definition: parser-defs.h:297
constrained_packed_array_type
static struct type * constrained_packed_array_type(struct type *, long *)
Definition: ada-lang.c:2201
min_of_size
static LONGEST min_of_size(int size)
Definition: ada-lang.c:764
expression::language_defn
const struct language_defn * language_defn
Definition: expression.h:80
language_def
const struct language_defn * language_def(enum language lang)
Definition: language.c:494
bp_location_ops
Definition: breakpoint.h:308
catch_assert_breakpoint_ops
static struct breakpoint_ops catch_assert_breakpoint_ops
Definition: ada-lang.c:13042
get_selections
int get_selections(int *choices, int n_choices, int max_results, int is_all_choice, const char *annotation_suffix)
Definition: ada-lang.c:4046
ada_decode
const char * ada_decode(const char *encoded)
Definition: ada-lang.c:1166
trust_pad_over_xvs
static int trust_pad_over_xvs
Definition: ada-lang.c:9513
ada_exception_name_addr
static CORE_ADDR ada_exception_name_addr(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:12435
LOC_UNDEF
Definition: symtab.h:797
inferior
Definition: inferior.h:310
ada_symbol_cache::cache_space
struct obstack cache_space
Definition: ada-lang.c:311
varobj.h
ada_print_typedef
void ada_print_typedef(struct type *type, struct symbol *new_symbol, struct ui_file *stream)
Definition: ada-typeprint.c:950
remove_irrelevant_renamings
static int remove_irrelevant_renamings(struct block_symbol *syms, int nsyms, const struct block *current_block)
Definition: ada-lang.c:5334
ada_get_gdb_completer_word_break_characters
static const char * ada_get_gdb_completer_word_break_characters(void)
Definition: ada-lang.c:561
breakpoint_ops::print_mention
void(* print_mention)(struct breakpoint *)
Definition: breakpoint.h:590
operator_check_standard
int operator_check_standard(struct expression *exp, int pos, int(*objfile_func)(struct objfile *objfile, void *data), void *data)
Definition: parse.c:1723
ada_type_match
static int ada_type_match(struct type *, struct type *, int)
Definition: ada-lang.c:3630
value_lazy
int value_lazy(const struct value *value)
Definition: value.c:1383
ada_print_type
void ada_print_type(struct type *, const char *, struct ui_file *, int, int, const struct type_print_options *)
Definition: ada-typeprint.c:830
_initialize_ada_language
void _initialize_ada_language(void)
Definition: ada-lang.c:14631
ada_primitive_type_long_double
Definition: ada-lang.c:14233
symbol_name_matcher_ftype
bool() symbol_name_matcher_ftype(const char *symbol_search_name, const lookup_name_info &lookup_name, completion_match_result *comp_match_res)
Definition: symtab.h:324
lval_internalvar
Definition: defs.h:387
exception_support_info
Definition: ada-lang.c:12025
default_read_var_value
struct value * default_read_var_value(struct symbol *var, const struct block *var_block, struct frame_info *frame)
Definition: findvar.c:587
value_assign_to_component
static void value_assign_to_component(struct value *container, struct value *component, struct value *val)
Definition: ada-lang.c:2804
completion_match::storage
std::string & storage()
Definition: completer.h:95
ALL_DOMAIN
Definition: symtab.h:786
coerce_ref
struct value * coerce_ref(struct value *arg)
Definition: value.c:3755
ensure_lval
static struct value * ensure_lval(struct value *val)
Definition: ada-lang.c:4474
block_linkage_function
struct symbol * block_linkage_function(const struct block *bl)
Definition: block.c:100
psymtab.h
class_vars
Definition: command.h:41
type_print
void type_print(struct type *type, const char *varstring, struct ui_file *stream, int show)
Definition: typeprint.c:358
selftests::scoped_restore_tests::global
static int global
Definition: scoped_restore-selftests.c:30
value_ind
struct value * value_ind(struct value *arg1)
Definition: valops.c:1542
frame_info
Definition: frame.c:85
gdbarch_long_bit
int gdbarch_long_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1596
parse_exp_1
expression_up parse_exp_1(const char **, CORE_ADDR pc, const struct block *, int)
Definition: parse.c:1089
value_copy
struct value * value_copy(struct value *arg)
Definition: value.c:1757
ada_exc_info::addr
CORE_ADDR addr
Definition: ada-lang.h:393
innermost_block
const struct block * innermost_block
Definition: parse.c:71
exception_support_info_fallback
static const struct exception_support_info exception_support_info_fallback
Definition: ada-lang.c:12070
ada_get_base_type
struct type * ada_get_base_type(struct type *raw_type)
Definition: ada-lang.c:9536
to_fixed_variant_branch_type
static struct type * to_fixed_variant_branch_type(struct type *, const gdb_byte *, CORE_ADDR, struct value *)
Definition: ada-lang.c:8801
ada_coerce_to_simple_array_type
struct type * ada_coerce_to_simple_array_type(struct type *type)
Definition: ada-lang.c:2102
value_from_contents_and_address_unresolved
struct value * value_from_contents_and_address_unresolved(struct type *type, const gdb_byte *valaddr, CORE_ADDR address)
Definition: value.c:3578
compunit_symtab
Definition: symtab.h:1380
TYPE_CODE_UNDEF
Definition: gdbtypes.h:83
breakpoint_ops::allocate_location
struct bp_location *(* allocate_location)(struct breakpoint *)
Definition: breakpoint.h:523
ada_print_subexp
static void ada_print_subexp(struct expression *exp, int *pos, struct ui_file *stream, enum precedence prec)
Definition: ada-lang.c:14053
ada_exception_message
static char * ada_exception_message(void)
Definition: ada-lang.c:12412
ada_primitive_type_void
Definition: ada-lang.c:14231
to_fixed_range_type
static struct type * to_fixed_range_type(struct type *, struct value *)
Definition: ada-lang.c:11848
ada_get_next_arg
static char * ada_get_next_arg(const char **argsp)
Definition: ada-lang.c:13099
observer_attach_inferior_exit
struct observer * observer_attach_inferior_exit(observer_inferior_exit_ftype *f)
UNDEF_DOMAIN
Definition: symtab.h:734
LOC_TYPEDEF
Definition: symtab.h:844
create_array_type_with_stride
struct type * create_array_type_with_stride(struct type *result_type, struct type *element_type, struct type *range_type, struct dynamic_prop *byte_stride_prop, unsigned int bit_stride)
Definition: gdbtypes.c:1147
BLOCKVECTOR_BLOCK
#define BLOCKVECTOR_BLOCK(blocklist, n)
Definition: block.h:125
ada_unhandled_exception_name_addr_ftype
CORE_ADDR() ada_unhandled_exception_name_addr_ftype(void)
Definition: ada-lang.c:12020
expression::nelts
int nelts
Definition: expression.h:83
ada_array_length
static LONGEST ada_array_length(struct value *arr, int n)
Definition: ada-lang.c:3158
ada_exception_message_1
static char * ada_exception_message_1(void)
Definition: ada-lang.c:12377
ada_add_block_symbols
static void ada_add_block_symbols(struct obstack *, const struct block *, const lookup_name_info &lookup_name, domain_enum, struct objfile *)
Definition: ada-lang.c:6271
ada_ignore_descriptive_types_p
static int ada_ignore_descriptive_types_p
Definition: ada-lang.c:372
ada_opname_map::decoded
const char * decoded
Definition: ada-lang.h:74
symtab::filename
const char * filename
Definition: symtab.h:1309
exception_support_info::catch_assert_sym
const char * catch_assert_sym
Definition: ada-lang.c:12037
cache_entry::domain
domain_enum domain
Definition: ada-lang.c:286
print_recreate_exception
static void print_recreate_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:12873
integer_type_p
static int integer_type_p(struct type *)
Definition: ada-lang.c:4179
static_unwrap_type
static struct type * static_unwrap_type(struct type *type)
Definition: ada-lang.c:9271
ada_value_primitive_field
static struct value * ada_value_primitive_field(struct value *, int, int, struct type *)
Definition: ada-lang.c:7214
exception_support_info::catch_exception_unhandled_sym
const char * catch_exception_unhandled_sym
Definition: ada-lang.c:12033
GROW_VECT
#define GROW_VECT(v, s, m)
Definition: ada-lang.h:156
cache_entry
Definition: ada-lang.c:281
skip_spaces
char * skip_spaces(char *chp)
Definition: common-utils.c:337
ada_primitive_type_int
Definition: ada-lang.c:14225
check_status_catch_exception
static void check_status_catch_exception(bpstat bs)
Definition: ada-lang.c:12919
cleanup
Definition: cleanups.c:38
known_runtime_file_name_patterns
static const char * known_runtime_file_name_patterns[]
Definition: ada-lang.c:340
STRUCT_DOMAIN
Definition: symtab.h:745
_
#define _(String)
Definition: gdb_locale.h:35
print_recreate_catch_exception_unhandled
static void print_recreate_catch_exception_unhandled(struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:12990
aux_add_nonlocal_symbols
static int aux_add_nonlocal_symbols(struct block *block, struct symbol *sym, void *data0)
Definition: ada-lang.c:5480
ui_file
Definition: ui-file.h:26
evaluate_subexp_type
static struct value * evaluate_subexp_type(struct expression *, int *)
Definition: ada-lang.c:9686
allocate_location_catch_assert
static struct bp_location * allocate_location_catch_assert(struct breakpoint *self)
Definition: ada-lang.c:13001
block_iter_match_first
struct symbol * block_iter_match_first(const struct block *block, const lookup_name_info &name, struct block_iterator *iterator)
Definition: block.c:639
find_function_start_sal
struct symtab_and_line find_function_start_sal(struct symbol *sym, int funfirstline)
Definition: symtab.c:3585
add_angle_brackets
static char * add_angle_brackets(const char *str)
Definition: ada-lang.c:551
language_arch_info::string_char_type
struct type * string_char_type
Definition: language.h:122
SET_FIELD_BITPOS
#define SET_FIELD_BITPOS(thisfld, bitpos)
Definition: gdbtypes.h:1352
ada_is_range_type_name
int ada_is_range_type_name(const char *name)
Definition: ada-lang.c:11944
defs.h
TYPE_FIELD
#define TYPE_FIELD(thistype, n)
Definition: gdbtypes.h:1370
gdbarch::obstack
struct obstack * obstack
Definition: gdbarch.c:133
general_symbol_info::obstack
struct obstack * obstack
Definition: symtab.h:420
builtin_type
Definition: gdbtypes.h:1495
scan_discrim_bound
static int scan_discrim_bound(const char *str, int k, struct value *dval, LONGEST *px, int *pnew_k)
Definition: ada-lang.c:11751
bits
#define bits(obj, st, fn)
Definition: aarch64-tdep.c:64
known_auxiliary_function_name_patterns
static const char * known_auxiliary_function_name_patterns[]
Definition: ada-lang.c:344
LOC_ARG
Definition: symtab.h:823
ada_check_typedef
struct type * ada_check_typedef(struct type *type)
Definition: ada-lang.c:9307
ada_lookup_name
static const char * ada_lookup_name(const lookup_name_info &lookup_name)
Definition: ada-lang.c:5656
ada_value_struct_elt
struct value * ada_value_struct_elt(struct value *arg, const char *name, int no_err)
Definition: ada-lang.c:7577
ada_get_symbol_name_matcher
static symbol_name_matcher_ftype * ada_get_symbol_name_matcher(const lookup_name_info &lookup_name)
Definition: ada-lang.c:14451
to_fixed_array_type
static struct type * to_fixed_array_type(struct type *, struct value *, int)
Definition: ada-lang.c:8919
ada_evaluate_subexp_for_cast
static value * ada_evaluate_subexp_for_cast(expression *exp, int *pos, enum noside noside, struct type *to_type)
Definition: ada-lang.c:10561
is_known_support_routine
static int is_known_support_routine(struct frame_info *frame)
Definition: ada-lang.c:12194
ada_lookup_struct_elt_type
static struct type * ada_lookup_struct_elt_type(struct type *, const char *, int, int)
Definition: ada-lang.c:7716
BYTES_TO_EXP_ELEM
#define BYTES_TO_EXP_ELEM(bytes)
Definition: expression.h:94
call_internal_function
struct value * call_internal_function(struct gdbarch *gdbarch, const struct language_defn *language, struct value *func, int argc, struct value **argv)
Definition: value.c:2533
TYPE_FIELD_ENUMVAL
#define TYPE_FIELD_ENUMVAL(thistype, n)
Definition: gdbtypes.h:1375
END_CATCH
#define END_CATCH
Definition: common-exceptions.h:259
ada_unpack_from_contents
static void ada_unpack_from_contents(const gdb_byte *src, int bit_offset, int bit_size, gdb_byte *unpacked, int unpacked_len, int is_big_endian, int is_signed_type, int is_scalar)
Definition: ada-lang.c:2430
TYPE_FIELD_TYPE
#define TYPE_FIELD_TYPE(thistype, n)
Definition: gdbtypes.h:1371
cache_entry::next
struct cache_entry * next
Definition: ada-lang.c:294
ada_aligned_value_addr
const gdb_byte * ada_aligned_value_addr(struct type *type, const gdb_byte *valaddr)
Definition: ada-lang.c:9597
VALUE_LVAL
#define VALUE_LVAL(val)
Definition: value.h:414
catch_ada_exception_command_split
static void catch_ada_exception_command_split(const char *args, bool is_catch_handlers_cmd, enum ada_exception_catchpoint_kind *ex, char **excep_string, char **cond_string)
Definition: ada-lang.c:13137
ada_is_string_type
int ada_is_string_type(struct type *type)
Definition: ada-lang.c:9487
allocate_value
struct value * allocate_value(struct type *type)
Definition: value.c:1036
show_ada_list
static struct cmd_list_element * show_ada_list
Definition: ada-lang.c:14546
ui_out::text
void text(const char *string)
Definition: ui-out.c:581
cleanup_check.ps
ps
Definition: cleanup_check.py:333
desc_base_type
static struct type * desc_base_type(struct type *)
Definition: ada-lang.c:1588
literal_symbol_name_matcher
static bool literal_symbol_name_matcher(const char *symbol_search_name, const lookup_name_info &lookup_name, completion_match_result *comp_match_res)
Definition: ada-lang.c:14428
print_it_catch_assert
static enum print_stop_action print_it_catch_assert(bpstat bs)
Definition: ada-lang.c:13019
print_recreate_catch_exception
static void print_recreate_catch_exception(struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:12943
maintenance_set_cmdlist
struct cmd_list_element * maintenance_set_cmdlist
Definition: maint.c:634
ADA_MAIN_PROGRAM_SYMBOL_NAME
static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
Definition: ada-lang.c:331
c_get_string
void c_get_string(struct value *value, gdb_byte **buffer, int *length, struct type **char_type, const char **charset)
Definition: c-lang.c:236
equiv_types
static int equiv_types(struct type *, struct type *)
Definition: ada-lang.c:4822
block_for_pc
const struct block * block_for_pc(CORE_ADDR pc)
Definition: block.c:282
ada_attribute_name
const char * ada_attribute_name(enum exp_opcode n)
Definition: ada-lang.c:9401
ada_unhandled_exception_name_addr
static CORE_ADDR ada_unhandled_exception_name_addr(void)
Definition: ada-lang.c:12273
ada_read_var_value
static struct value * ada_read_var_value(struct symbol *var, const struct block *var_block, struct frame_info *frame)
Definition: ada-lang.c:14470
LOC_LOCAL
Definition: symtab.h:839
case_sensitive_on
Definition: language.h:92
printf_filtered
void printf_filtered(const char *format,...)
Definition: utils.c:2045
op_print
Definition: parser-defs.h:305
ada_is_exception_sym
static int ada_is_exception_sym(struct symbol *sym)
Definition: ada-lang.c:13524
longest_to_int
int longest_to_int(LONGEST)
Definition: valprint.c:1341
ada_remove_Xbn_suffix
static void ada_remove_Xbn_suffix(const char *encoded, int *len)
Definition: ada-lang.c:1140
paddress
const char * paddress(struct gdbarch *gdbarch, CORE_ADDR addr)
Definition: utils.c:2745
objfiles.h
ada_exception_sym_name
static const char * ada_exception_sym_name(enum ada_exception_catchpoint_kind ex)
Definition: ada-lang.c:13215
multiple_symbols_select_mode
const char * multiple_symbols_select_mode(void)
Definition: symtab.c:252
new_type
static struct type * new_type(char *)
Definition: mdebugread.c:4852
ada_find_parallel_type_with_name
static struct type * ada_find_parallel_type_with_name(struct type *, const char *)
Definition: ada-lang.c:8226
create_excep_cond_exprs
static void create_excep_cond_exprs(struct ada_catchpoint *c, enum ada_exception_catchpoint_kind ex)
Definition: ada-lang.c:12520
return_match
static int return_match(struct type *func_type, struct type *context_type)
Definition: ada-lang.c:3725
completion_match_result
Definition: completer.h:205
xget_renaming_scope
static char * xget_renaming_scope(struct type *renaming_type)
Definition: ada-lang.c:5194
arch_integer_type
struct type * arch_integer_type(struct gdbarch *gdbarch, int bit, int unsigned_p, const char *name)
Definition: gdbtypes.c:4962
arch-utils.h
PREC_LOGICAL_OR
Definition: parser-defs.h:296
ada_index_type
static struct type * ada_index_type(struct type *type, int n, const char *name)
Definition: ada-lang.c:3040
ada_lookup_name_info::ada_lookup_name_info
ada_lookup_name_info(const lookup_name_info &lookup_name)
Definition: ada-lang.c:14354
dump_subexp
int dump_subexp(struct expression *exp, struct ui_file *stream, int elt)
Definition: expprint.c:761
type_from_tag
static struct type * type_from_tag(struct value *tag)
Definition: ada-lang.c:6738
language_defn
Definition: language.h:132
exp_element::symbol
struct symbol * symbol
Definition: expression.h:65
BLOCK_FUNCTION
#define BLOCK_FUNCTION(bl)
Definition: block.h:107
possible_user_operator_p
static int possible_user_operator_p(enum exp_opcode, struct value **)
initialize_ada_catchpoint_ops
static void initialize_ada_catchpoint_ops(void)
Definition: ada-lang.c:14567
deprecated_set_value_type
void deprecated_set_value_type(struct value *value, struct type *type)
Definition: value.c:1100
cast_from_fixed
static struct value * cast_from_fixed(struct type *type, struct value *arg)
Definition: ada-lang.c:9729
LOC_REGISTER
Definition: symtab.h:819
ada_tag_type
struct type * ada_tag_type(struct value *val)
Definition: ada-lang.c:6690
decode_constrained_packed_array_type
static struct type * decode_constrained_packed_array_type(struct type *)
Definition: ada-lang.c:2249
observer.h
exp_element::type
struct type * type
Definition: expression.h:72
set_value_address
void set_value_address(struct value *value, CORE_ADDR addr)
Definition: value.c:1553
symtab_to_fullname
const char * symtab_to_fullname(struct symtab *s)
Definition: source.c:1131
ada_lookup_symbol_list
int ada_lookup_symbol_list(const char *name, const struct block *block, domain_enum domain, struct block_symbol **results)
Definition: ada-lang.c:5869
add_prefix_cmd
struct cmd_list_element * add_prefix_cmd(const char *name, enum command_class theclass, cmd_const_cfunc_ftype *fun, const char *doc, struct cmd_list_element **prefixlist, const char *prefixname, int allow_unknown, struct cmd_list_element **list)
Definition: cli-decode.c:367
is_ada95_tag
static int is_ada95_tag(struct value *tag)
Definition: ada-lang.c:6699
lookup_name_info::match_type
symbol_name_match_type match_type() const
Definition: symtab.h:194
cache_symbol
static void cache_symbol(const char *name, domain_enum domain, struct symbol *sym, const struct block *block)
Definition: ada-lang.c:4729
value_subscript_packed
static struct value * value_subscript_packed(struct value *, int, struct value **)
Definition: ada-lang.c:2352
GLOBAL_BLOCK
Definition: defs.h:686
parser-defs.h
flags
mach_port_t kern_return_t mach_port_t msgports mach_port_t kern_return_t pid_t pid mach_port_t kern_return_t mach_port_t task mach_port_t kern_return_t int flags
Definition: gnu-nat.c:1891
ada_collect_symbol_completion_matches
static void ada_collect_symbol_completion_matches(completion_tracker &tracker, complete_symbol_mode mode, symbol_name_match_type name_match_type, const char *text, const char *word, enum type_code code)
Definition: ada-lang.c:6465
ada_primitive_type_storage_offset
Definition: ada-lang.c:14237
ada_yyerror
void ada_yyerror(const char *)
symbols_are_identical_enums
static int symbols_are_identical_enums(struct block_symbol *syms, int nsyms)
Definition: ada-lang.c:5061
null_cleanup
void null_cleanup(void *arg)
Definition: cleanups.c:294
re_set_catch_exception
static void re_set_catch_exception(struct breakpoint *b)
Definition: ada-lang.c:12913
unwrap_value
static struct value * unwrap_value(struct value *)
Definition: ada-lang.c:9695
evaluate_expression
struct value * evaluate_expression(struct expression *exp)
Definition: eval.c:144
TYPE_CODE_STRING
Definition: gdbtypes.h:133
TRY
#define TRY
Definition: common-exceptions.h:246
ada_array_bound_from_type
static LONGEST ada_array_bound_from_type(struct type *arr_type, int n, int which)
Definition: ada-lang.c:3079
print_recreate_catch_assert
static void print_recreate_catch_assert(struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:13037
TYPE_CODE_VOID
Definition: gdbtypes.h:124
has_negatives
static int has_negatives(struct type *type)
Definition: ada-lang.c:2402
symtab.h
print_it_catch_exception
static enum print_stop_action print_it_catch_exception(bpstat bs)
Definition: ada-lang.c:12925
R
#define R(name, type, sim_num)
Definition: m32c-tdep.c:727
exp_element::block
const struct block * block
Definition: expression.h:74
ada_coerce_to_simple_array_ptr
struct value * ada_coerce_to_simple_array_ptr(struct value *arr)
Definition: ada-lang.c:2059
array_row_major
Definition: language.h:81
ada_index_struct_field_1
static struct value * ada_index_struct_field_1(int *, struct value *, int, struct type *)
Definition: ada-lang.c:7529
value_ptradd
struct value * value_ptradd(struct value *arg1, LONGEST arg2)
Definition: valarith.c:80
ada_find_any_type
static struct type * ada_find_any_type(const char *name)
Definition: ada-lang.c:8020
TYPE_CODE_TYPEDEF
Definition: gdbtypes.h:169
ada_add_standard_exceptions
static void ada_add_standard_exceptions(compiled_regex *preg, std::vector< ada_exc_info > *exceptions)
Definition: ada-lang.c:13610
eval_skip_value
value * eval_skip_value(expression *exp)
Definition: eval.c:761
get_int_var_value
bool get_int_var_value(const char *name, LONGEST &value)
Definition: ada-lang.c:11826
ada_find_printable_frame
void ada_find_printable_frame(struct frame_info *fi)
Definition: ada-lang.c:12253
discrete_position
int discrete_position(struct type *type, LONGEST val, LONGEST *pos)
Definition: gdbtypes.c:1100
lval_memory
Definition: defs.h:383
setlist
struct cmd_list_element * setlist
Definition: cli-cmds.c:111
name
const char *const name
Definition: aarch64-tdep.c:76
is_thick_pntr
static int is_thick_pntr(struct type *type)
Definition: ada-lang.c:1655
lim_warning
static void lim_warning(const char *format,...) ATTRIBUTE_PRINTF(1
Definition: ada-lang.c:730
SYMTAB_BLOCKVECTOR
#define SYMTAB_BLOCKVECTOR(symtab)
Definition: symtab.h:1334
ada_scaling_factor
struct value * ada_scaling_factor(struct type *type)
Definition: ada-lang.c:11719
evaluate_var_msym_value
value * evaluate_var_msym_value(enum noside noside, struct objfile *objfile, minimal_symbol *msymbol)
Definition: eval.c:742
value_struct_elt
struct value * value_struct_elt(struct value **argp, struct value **args, const char *name, int *static_memfuncp, const char *err)
Definition: valops.c:2133
ada_unhandled_exception_name_addr_from_raise
static CORE_ADDR ada_unhandled_exception_name_addr_from_raise(void)
Definition: ada-lang.c:12284
ada_renaming_category
ada_renaming_category
Definition: ada-lang.h:83
catch_ada_assert_command_split
static void catch_ada_assert_command_split(const char *args, char **cond_string)
Definition: ada-lang.c:13478
ada_main_name
char * ada_main_name(void)
Definition: ada-lang.c:916
check_typedef
struct type * check_typedef(struct type *type)
Definition: gdbtypes.c:2421
print_it_catch_handlers
static enum print_stop_action print_it_catch_handlers(bpstat bs)
Definition: ada-lang.c:13065
SYMBOL_VALUE_ADDRESS
#define SYMBOL_VALUE_ADDRESS(symbol)
Definition: symtab.h:464
emit_char
static void emit_char(int c, struct type *type, struct ui_file *stream, int quoter)
Definition: ada-lang.c:14311
ada_evaluate_subexp
static struct value * ada_evaluate_subexp(struct type *, struct expression *, int *, enum noside)
Definition: ada-lang.c:10612
ada_fixup_array_indexes_type
void ada_fixup_array_indexes_type(struct type *index_desc_type)
Definition: ada-lang.c:1538
coerce_unspec_val_to_type
static struct value * coerce_unspec_val_to_type(struct value *, struct type *)
Definition: ada-lang.c:673
print_signatures
static int print_signatures
Definition: ada-lang.c:3870
value_contents
const gdb_byte * value_contents(struct value *value)
Definition: value.c:1407
lesseq_defined_than
static int lesseq_defined_than(struct symbol *, struct symbol *)
Definition: ada-lang.c:4842
CATCH
#define CATCH(EXCEPTION, MASK)
Definition: common-exceptions.h:254
LOC_COMPUTED
Definition: symtab.h:892
breakpoint::disposition
bpdisp disposition
Definition: breakpoint.h:697
contained_in
int contained_in(const struct block *a, const struct block *b)
Definition: block.c:73
maint_set_ada_cmdlist
static struct cmd_list_element * maint_set_ada_cmdlist
Definition: ada-lang.c:350
value_print_options
Definition: valprint.h:25
TYPE_CODE_CHAR
Definition: gdbtypes.h:160
print_mention_catch_assert
static void print_mention_catch_assert(struct breakpoint *b)
Definition: ada-lang.c:13031
get_ada_pspace_data
static struct ada_pspace_data * get_ada_pspace_data(struct program_space *pspace)
Definition: ada-lang.c:458
block_iter_match_next
struct symbol * block_iter_match_next(const lookup_name_info &name, struct block_iterator *iterator)
Definition: block.c:654
find_struct_field
static int find_struct_field(const char *, struct type *, int, struct type **, int *, int *, int *, int *)
Definition: ada-lang.c:7303
TYPE_MAIN_TYPE
#define TYPE_MAIN_TYPE(thistype)
Definition: gdbtypes.h:1223
language_arch_info::bool_type_default
struct type * bool_type_default
Definition: language.h:127
gdb::unique_xmalloc_ptr
std::unique_ptr< T, xfree_deleter< T > > unique_xmalloc_ptr
Definition: gdb_unique_ptr.h:48
ada_forward_operator_length
static void ada_forward_operator_length(struct expression *, int, int *, int *)
Definition: ada-lang.c:13944
cache_entry::sym
struct symbol * sym
Definition: ada-lang.c:289
ada_lookup_name_info::m_wild_match_p
bool m_wild_match_p
Definition: symtab.h:128
ada_same_array_size_p
static int ada_same_array_size_p(struct type *t1, struct type *t2)
Definition: ada-lang.c:9758
fixed_type_info
static const char * fixed_type_info(struct type *type)
Definition: ada-lang.c:11649
SYMBOL_DOMAIN
#define SYMBOL_DOMAIN(symbol)
Definition: symtab.h:1152
ada_prefer_type
int ada_prefer_type(struct type *type0, struct type *type1)
Definition: ada-lang.c:8118
bpstats::bp_location_at
struct bp_location * bp_location_at
Definition: breakpoint.h:1116
objfile::objfile
objfile(bfd *, const char *, objfile_flags)
Definition: objfiles.c:373
ada_discrete_type_high_bound
LONGEST ada_discrete_type_high_bound(struct type *type)
Definition: ada-lang.c:800
PREC_MUL
Definition: parser-defs.h:298
alloc_type_copy
struct type * alloc_type_copy(const struct type *type)
Definition: gdbtypes.c:222
parse_old_style_renaming
static enum ada_renaming_category parse_old_style_renaming(struct type *, const char **, int *, const char **)
Definition: ada-lang.c:4397
language_ada
Definition: defs.h:219
show_ada_command
static void show_ada_command(const char *args, int from_tty)
Definition: ada-lang.c:14561
fprintf_filtered
void fprintf_filtered(struct ui_file *stream, const char *format,...)
Definition: utils.c:2008
defns_collected
static struct block_symbol * defns_collected(struct obstack *, int)
Definition: ada-lang.c:4930
ada_modulus
ULONGEST ada_modulus(struct type *type)
Definition: ada-lang.c:11967
encoded_ordered_before
static int encoded_ordered_before(const char *N0, const char *N1)
Definition: ada-lang.c:3812
align_value
static unsigned int align_value(unsigned int off, unsigned int alignment)
Definition: ada-lang.c:7964
xzalloc
void * xzalloc(size_t size)
Definition: common-utils.c:92
SYMTAB_OBJFILE
#define SYMTAB_OBJFILE(symtab)
Definition: symtab.h:1336
ada_is_tagged_type
int ada_is_tagged_type(struct type *type, int refok)
Definition: ada-lang.c:6664
extract_unsigned_integer
static ULONGEST extract_unsigned_integer(const gdb_byte *addr, int len, enum bfd_endian byte_order)
Definition: defs.h:577
arch_float_type
struct type * arch_float_type(struct gdbarch *gdbarch, int bit, const char *name, const struct floatformat **floatformats)
Definition: gdbtypes.c:5014
block_symbol::block
const struct block * block
Definition: symtab.h:1140
umax_of_size
static ULONGEST umax_of_size(int size)
Definition: ada-lang.c:771
create_ada_exception_catchpoint
void create_ada_exception_catchpoint(struct gdbarch *gdbarch, enum ada_exception_catchpoint_kind ex_kind, char *excep_string, char *cond_string, int tempflag, int disabled, int from_tty)
Definition: ada-lang.c:13396
decode_packed_array_bitsize
static long decode_packed_array_bitsize(struct type *)
Definition: ada-lang.c:2151
get_frame_block
const struct block * get_frame_block(struct frame_info *frame, CORE_ADDR *addr_in_block)
Definition: blockframe.c:55
ada_name_prefix_len
int ada_name_prefix_len(const char *name)
Definition: ada-lang.c:639
ada_is_simple_array_type
int ada_is_simple_array_type(struct type *type)
Definition: ada-lang.c:1929
bound_minimal_symbol
Definition: minsyms.h:29
value_cast_pointers
struct value * value_cast_pointers(struct type *type, struct value *arg2, int subclass_check)
Definition: valops.c:306
ada_exceptions_list
std::vector< ada_exc_info > ada_exceptions_list(const char *regexp)
Definition: ada-lang.c:13807
ada_catchpoint_location::excep_cond_expr
expression_up excep_cond_expr
Definition: ada-lang.c:12485
find_parallel_type_by_descriptive_type
static struct type * find_parallel_type_by_descriptive_type(struct type *type, const char *name)
Definition: ada-lang.c:8165
is_lower_alphanum
static int is_lower_alphanum(const char c)
Definition: ada-lang.c:1078
ada_op_print_tab
static const struct op_print ada_op_print_tab[]
Definition: ada-lang.c:14189
lookup_name_info::match_any
static const lookup_name_info & match_any()
Definition: symtab.c:1794
find_old_style_renaming_symbol
static struct symbol * find_old_style_renaming_symbol(const char *, const struct block *)
Definition: ada-lang.c:8059
scalar_type_p
static int scalar_type_p(struct type *)
Definition: ada-lang.c:4201
decoded_names_store
static struct htab * decoded_names_store
Definition: ada-lang.c:1417
language_auto
Definition: defs.h:206
maint_show_ada_cmd
static void maint_show_ada_cmd(const char *args, int from_tty)
Definition: ada-lang.c:365
showlist
struct cmd_list_element * showlist
Definition: cli-cmds.c:119
ada_template_to_fixed_record_type_1
struct type * ada_template_to_fixed_record_type_1(struct type *type, const gdb_byte *valaddr, CORE_ADDR address, struct value *dval0, int keep_dynamic_fields)
Definition: ada-lang.c:8350
do_wild_match
static bool do_wild_match(const char *symbol_search_name, const lookup_name_info &lookup_name, completion_match_result *comp_match_res)
Definition: ada-lang.c:14335
namespace.h
value_contents_all
const gdb_byte * value_contents_all(struct value *value)
Definition: value.c:1265
max_of_type
static LONGEST max_of_type(struct type *t)
Definition: ada-lang.c:780
cli-utils.h
expression
Definition: expression.h:78
block_symbol
Definition: symtab.h:1133
fputs_filtered
void fputs_filtered(const char *linebuffer, struct ui_file *stream)
Definition: utils.c:1811
frame.h
streq
int streq(const char *lhs, const char *rhs)
Definition: utils.c:2641
TYPE_CODE_FLT
Definition: gdbtypes.h:116
expression.h
ada_is_system_address_type
int ada_is_system_address_type(struct type *type)
Definition: ada-lang.c:11680
set_value_parent
void set_value_parent(struct value *value, struct value *parent)
Definition: value.c:1147
ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS
#define ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS
Definition: ada-lang.h:53
is_integral_type
int is_integral_type(struct type *t)
Definition: gdbtypes.c:3027
language_arch_info::bool_type_symbol
const char * bool_type_symbol
Definition: language.h:125
match_data::arg_sym
struct symbol * arg_sym
Definition: ada-lang.c:5466
objfile::sf
const struct sym_fns * sf
Definition: objfiles.h:381
unop_promote
void unop_promote(const struct language_defn *language, struct gdbarch *gdbarch, struct value **arg1)
Definition: eval.c:419
varsize_limit
static unsigned int varsize_limit
Definition: ada-lang.c:320
ada_inferior_data::exception_info
const struct exception_support_info * exception_info
Definition: ada-lang.c:389
default_pass_by_reference
int default_pass_by_reference(struct type *type)
Definition: language.c:669
get_ada_inferior_data
static struct ada_inferior_data * get_ada_inferior_data(struct inferior *inf)
Definition: ada-lang.c:415
desc_bound_bitsize
static int desc_bound_bitsize(struct type *, int, int)
Definition: ada-lang.c:1862
gdbarch_byte_order
enum bfd_endian gdbarch_byte_order(struct gdbarch *gdbarch)
Definition: gdbarch.c:1509
current_uiout
#define current_uiout
Definition: ui-out.h:39
breakpoint
Definition: breakpoint.h:684
inferior.h
basic_lookup_transparent_type
struct type * basic_lookup_transparent_type(const char *name)
Definition: symtab.c:2792
make_cleanup
struct cleanup * make_cleanup(make_cleanup_ftype *function, void *arg)
Definition: cleanups.c:116
set_ada_list
static struct cmd_list_element * set_ada_list
Definition: ada-lang.c:14545
op_string
const char * op_string(enum exp_opcode op)
Definition: expprint.c:666
is_nonfunction
static int is_nonfunction(struct block_symbol *, int)
TYPE_CODE_UNION
Definition: gdbtypes.h:107
add_component_interval
static void add_component_interval(LONGEST, LONGEST, LONGEST *, int *, int)
Definition: ada-lang.c:10249
ada_lookup_name_info::standard_p
bool standard_p() const
Definition: symtab.h:110
CATCH_PERMANENT
#define CATCH_PERMANENT
Definition: breakpoint.h:1282
ALL_COMPUNITS
#define ALL_COMPUNITS(objfile, cu)
Definition: objfiles.h:619
block_using
struct using_direct * block_using(const struct block *block)
Definition: block.c:324
TARGET_CHAR_BIT
#define TARGET_CHAR_BIT
Definition: host-defs.h:29
ada_lookup_name_info::m_standard_p
bool m_standard_p
Definition: symtab.h:145
ada_free_symbol_cache
static void ada_free_symbol_cache(struct ada_symbol_cache *sym_cache)
Definition: ada-lang.c:4650
nr_ada_primitive_types
Definition: ada-lang.c:14238
ada_delta
struct value * ada_delta(struct type *type)
Definition: ada-lang.c:11701
ada_primitive_type_positive
Definition: ada-lang.c:14235
ada_value_cast
static struct value * ada_value_cast(struct type *type, struct value *arg2)
Definition: ada-lang.c:10288
ada_is_packed_array_type
static int ada_is_packed_array_type(struct type *)
Definition: ada-lang.c:2116
ada_find_parallel_type
struct type * ada_find_parallel_type(struct type *type, const char *suffix)
Definition: ada-lang.c:8242
ATTRIBUTE_PRINTF
#define ATTRIBUTE_PRINTF
Definition: common-defs.h:70
type
Definition: gdbtypes.h:749
completion_skip_symbol
static bool completion_skip_symbol(complete_symbol_mode mode, Symbol *sym)
Definition: symtab.h:1880
aggregate_assign_from_choices
static void aggregate_assign_from_choices(struct value *, struct value *, struct expression *, int *, LONGEST *, int *, int, LONGEST, LONGEST)
Definition: ada-lang.c:10139
ada_language_arch_info
static void ada_language_arch_info(struct gdbarch *, struct language_arch_info *)
Definition: ada-lang.c:14242
language.h
ada_primitive_type_char
Definition: ada-lang.c:14228
ada_symbol_cache
Definition: ada-lang.c:308
byte-vector.h
standard_lookup
static struct symbol * standard_lookup(const char *, const struct block *, domain_enum)
Definition: ada-lang.c:4787
ada_symbol_name_matches
static bool ada_symbol_name_matches(const char *symbol_search_name, const lookup_name_info &lookup_name, completion_match_result *comp_match_res)
Definition: ada-lang.c:14415
is_package_name
static int is_package_name(const char *name)
Definition: ada-lang.c:5228
using_direct::searched
int searched
Definition: namespace.h:102
ada_symbol_cache::root
struct cache_entry * root[HASH_SIZE]
Definition: ada-lang.c:314
LOC_CONST
Definition: symtab.h:801
LOC_UNRESOLVED
Definition: symtab.h:883
cache_entry::block
const struct block * block
Definition: ada-lang.c:292
BLOCK_SUPERBLOCK
#define BLOCK_SUPERBLOCK(bl)
Definition: block.h:108
general_symbol_info::language_specific
union general_symbol_info::@172 language_specific
exp_element::string
char string
Definition: expression.h:71
ada_is_wrapper_field
int ada_is_wrapper_field(struct type *type, int field_num)
Definition: ada-lang.c:7002
get_type_arch
struct gdbarch * get_type_arch(const struct type *type)
Definition: gdbtypes.c:234
using_direct
Definition: namespace.h:90
bp_location::next
bp_location * next
Definition: breakpoint.h:324
ada_is_unconstrained_packed_array_type
static int ada_is_unconstrained_packed_array_type(struct type *)
Definition: ada-lang.c:2141
ada_lookup_name_info::m_encoded_name
std::string m_encoded_name
Definition: symtab.h:119
inf
Definition: gnu-nat.c:174
get_current_arch
struct gdbarch * get_current_arch(void)
Definition: arch-utils.c:798
value_contents_writeable
gdb_byte * value_contents_writeable(struct value *value)
Definition: value.c:1416
min_of_type
static LONGEST min_of_type(struct type *t)
Definition: ada-lang.c:790
ada_type_of_array
struct type * ada_type_of_array(struct value *arr, int bounds)
Definition: ada-lang.c:1980
value_assign
struct value * value_assign(struct value *toval, struct value *fromval)
Definition: valops.c:993
type
static const char * type
Definition: language.c:113
dump_subexp_body_standard
int dump_subexp_body_standard(struct expression *exp, struct ui_file *stream, int elt)
Definition: expprint.c:795
add_symbols_from_enclosing_procs
static void add_symbols_from_enclosing_procs(struct obstack *obstackp, const lookup_name_info &lookup_name, domain_enum domain)
Definition: ada-lang.c:4980
language_bool_type
struct type * language_bool_type(const struct language_defn *la, struct gdbarch *gdbarch)
Definition: language.c:982
EVAL_AVOID_SIDE_EFFECTS
Definition: expression.h:127
desc_bounds_type
static struct type * desc_bounds_type(struct type *)
Definition: ada-lang.c:1666
field
Definition: gdbtypes.h:517
gdbarch_double_bit
int gdbarch_double_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1713
value_from_longest
struct value * value_from_longest(struct type *type, LONGEST num)
Definition: value.c:3534
SYMBOL_LINE
#define SYMBOL_LINE(symbol)
Definition: symtab.h:1162
SYMBOL_LINKAGE_NAME
#define SYMBOL_LINKAGE_NAME(symbol)
Definition: symtab.h:523
exception_fprintf
void exception_fprintf(struct ui_file *file, struct gdb_exception e, const char *prefix,...)
Definition: exceptions.c:119
allocate_location_catch_exception_unhandled
static struct bp_location * allocate_location_catch_exception_unhandled(struct breakpoint *self)
Definition: ada-lang.c:12953
startswith
static int startswith(const char *string, const char *pattern)
Definition: common-utils.h:107
remove_extra_symbols
static int remove_extra_symbols(struct block_symbol *syms, int nsyms)
Definition: ada-lang.c:5107
ada_array_bound
static LONGEST ada_array_bound(struct value *arr, int n, int which)
Definition: ada-lang.c:3135
ada_value_equal
static int ada_value_equal(struct value *arg1, struct value *arg2)
Definition: ada-lang.c:9924
value_at_lazy
struct value * value_at_lazy(struct type *type, CORE_ADDR addr)
Definition: valops.c:944
aggregate_assign_others
static void aggregate_assign_others(struct value *, struct value *, struct expression *, int *, LONGEST *, int, LONGEST, LONGEST)
Definition: ada-lang.c:10221
value_cast
struct value * value_cast(struct type *type, struct value *arg2)
Definition: valops.c:351
EVAL_SKIP
Definition: expression.h:126
global_block
Definition: block.h:94
LOC_STATIC
Definition: symtab.h:805
print_mention_catch_handlers
static void print_mention_catch_handlers(struct breakpoint *b)
Definition: ada-lang.c:13078
ada_catchpoint
Definition: ada-lang.c:12508
match_data::found_sym
int found_sym
Definition: ada-lang.c:5467
skip_to_space
const char * skip_to_space(const char *chp)
Definition: common-utils.c:361
to_record_with_fixed_variant_part
static struct type * to_record_with_fixed_variant_part(struct type *type, const gdb_byte *valaddr, CORE_ADDR address, struct value *dval0)
Definition: ada-lang.c:8683
ada_catchpoint_location
Definition: ada-lang.c:12475
EXEC_ASYNC_BREAKPOINT_HIT
Definition: mi-common.h:31
ada_is_array_descriptor_type
int ada_is_array_descriptor_type(struct type *type)
Definition: ada-lang.c:1943
ada_inferior_data::tsd_type
struct type * tsd_type
Definition: ada-lang.c:384
set_value_offset
void set_value_offset(struct value *value, LONGEST offset)
Definition: value.c:1111
xstrprintf
char * xstrprintf(const char *format,...)
Definition: common-utils.c:107
template_to_static_fixed_type
static struct type * template_to_static_fixed_type(struct type *type0)
Definition: ada-lang.c:8614
parser_state
Definition: parser-defs.h:38
NULL_TYPE
#define NULL_TYPE
Definition: gdbtypes.h:810
breakpoint.h
printf_unfiltered
void printf_unfiltered(const char *format,...)
Definition: utils.c:2056
TRUNCATION_TOWARDS_ZERO
#define TRUNCATION_TOWARDS_ZERO
Definition: ada-lang.c:72
ada_to_fixed_type_1
static struct type * ada_to_fixed_type_1(struct type *type, const gdb_byte *valaddr, CORE_ADDR address, struct value *dval, int check_tag)
Definition: ada-lang.c:9072
value_bitpos
LONGEST value_bitpos(const struct value *value)
Definition: value.c:1117
ada_encode_1
static char * ada_encode_1(const char *decoded, bool throw_errors)
Definition: ada-lang.c:986
print_it_exception
static enum print_stop_action print_it_exception(enum ada_exception_catchpoint_kind ex, bpstat bs)
Definition: ada-lang.c:12663
TYPE_FIELDS
#define TYPE_FIELDS(thistype)
Definition: gdbtypes.h:1240
ada_add_local_symbols
static void ada_add_local_symbols(struct obstack *obstackp, const lookup_name_info &lookup_name, const struct block *block, domain_enum domain)
Definition: ada-lang.c:5434
read_memory
void read_memory(CORE_ADDR memaddr, gdb_byte *myaddr, ssize_t len)
Definition: corefile.c:258
value_print_options::addressprint
int addressprint
Definition: valprint.h:43
symtab
Definition: symtab.h:1291
ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS
#define ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS
Definition: ada-lang.h:45
LOC_REGPARM_ADDR
Definition: symtab.h:835
empty_array
static struct value * empty_array(struct type *arr_type, int low)
Definition: ada-lang.c:3201
field_alignment
static unsigned int field_alignment(struct type *type, int f)
Definition: ada-lang.c:7972
ada_read_renaming_var_value
static struct value * ada_read_renaming_var_value(struct symbol *renaming_sym, const struct block *block)
Definition: ada-lang.c:4456
objfile_name
const char * objfile_name(const struct objfile *objfile)
Definition: objfiles.c:1557
value_equal
int value_equal(struct value *arg1, struct value *arg2)
Definition: valarith.c:1474
ada_inferior_data
static const struct inferior_data * ada_inferior_data
Definition: ada-lang.c:393
check_status_catch_handlers
static void check_status_catch_handlers(bpstat bs)
Definition: ada-lang.c:13059
bkpt_breakpoint_ops
struct breakpoint_ops bkpt_breakpoint_ops
Definition: breakpoint.c:255
ada_op_name
static const char * ada_op_name(enum exp_opcode)
Definition: ada-lang.c:13919
gdb_print_host_address
#define gdb_print_host_address(ADDR, STREAM)
Definition: utils.h:438
xmalloc
void * xmalloc(YYSIZE_T)
symtab_and_line::symtab
struct symtab * symtab
Definition: symtab.h:1751
fat_pntr_data_bitpos
static int fat_pntr_data_bitpos(struct type *)
Definition: ada-lang.c:1817
msymbol_hash
unsigned int msymbol_hash(const char *string)
Definition: minsyms.c:126
ada_pspace_data::sym_cache
struct ada_symbol_cache * sym_cache
Definition: ada-lang.c:446
ada_catchpoint::excep_string
char * excep_string
Definition: ada-lang.c:12513
TYPE_CODE_STRUCT
Definition: gdbtypes.h:106
variant_field_index
static int variant_field_index(struct type *type)
Definition: ada-lang.c:8300
TYPE_FIELD_BITSIZE
#define TYPE_FIELD_BITSIZE(thistype, n)
Definition: gdbtypes.h:1380
EXP_ELEM_TO_BYTES
#define EXP_ELEM_TO_BYTES(elements)
Definition: expression.h:92
ada_value_print
void ada_value_print(struct value *, struct ui_file *, const struct value_print_options *)
Definition: ada-valprint.c:1186
builtin_type::builtin_bool
struct type * builtin_bool
Definition: gdbtypes.h:1516
ada_is_dispatch_table_ptr_type
static int ada_is_dispatch_table_ptr_type(struct type *type)
Definition: ada-lang.c:6592
ada_exc_info
Definition: ada-lang.h:387
ada_get_decoded_type
struct type * ada_get_decoded_type(struct type *type)
Definition: ada-lang.c:886
ada_value_subscript
struct value * ada_value_subscript(struct value *arr, int arity, struct value **ind)
Definition: ada-lang.c:2837
lookup_struct_elt_type
struct type * lookup_struct_elt_type(struct type *type, const char *name, int noerr)
Definition: gdbtypes.c:1662
TYPE_CODE_REF
Definition: gdbtypes.h:156
ada_tag_name_from_tsd
static char * ada_tag_name_from_tsd(struct value *tsd)
Definition: ada-lang.c:6897
cmd_show_list
void cmd_show_list(struct cmd_list_element *list, int from_tty, const char *prefix)
Definition: cli-setshow.c:657
breakpoint_ops::check_status
void(* check_status)(struct bpstats *bs)
Definition: breakpoint.h:554
TYPE_CODE_FUNC
Definition: gdbtypes.h:110
ada_opname_map
Definition: ada-lang.h:71
TYPE_FIELD_BITPOS
#define TYPE_FIELD_BITPOS(thistype, n)
Definition: gdbtypes.h:1374
ada_parse_renaming
enum ada_renaming_category ada_parse_renaming(struct symbol *sym, const char **renamed_entity, int *len, const char **renaming_expr)
Definition: ada-lang.c:4332
type_as_string
static std::string type_as_string(struct type *type)
Definition: ada-lang.c:7686
ada_is_redundant_index_type_desc
static int ada_is_redundant_index_type_desc(struct type *array_type, struct type *desc_type)
Definition: ada-lang.c:8893
print_one_catch_assert
static void print_one_catch_assert(struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:13025
ada_is_constrained_packed_array_type
int ada_is_constrained_packed_array_type(struct type *type)
Definition: ada-lang.c:2131
TYPE_UNSIGNED
#define TYPE_UNSIGNED(t)
Definition: gdbtypes.h:205
block_symbol::symbol
struct symbol * symbol
Definition: symtab.h:1136
ada_is_interface_tag
static int ada_is_interface_tag(struct type *type)
Definition: ada-lang.c:6609
SYMBOL_VALUE
#define SYMBOL_VALUE(symbol)
Definition: symtab.h:463
general_symbol_info::name
const char * name
Definition: symtab.h:384
ada_new_objfile_observer
static void ada_new_objfile_observer(struct objfile *objfile)
Definition: ada-lang.c:14617
reg
Definition: regdef.h:22
string_file::string
std::string & string()
Definition: ui-file.h:132
re_set_exception
static void re_set_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:12595
ada_tag_value_at_base_address
struct value * ada_tag_value_at_base_address(struct value *obj)
Definition: ada-lang.c:6754
LOC_REF_ARG
Definition: symtab.h:827
info_exceptions_command
static void info_exceptions_command(const char *regexp, int from_tty)
Definition: ada-lang.c:13819
ada_is_tag_type
int ada_is_tag_type(struct type *type)
Definition: ada-lang.c:6672
gdb_assert
#define gdb_assert(expr)
Definition: gdb_assert.h:32
block
Definition: block.h:60
ALL_OBJFILE_COMPUNITS
#define ALL_OBJFILE_COMPUNITS(objfile, cu)
Definition: objfiles.h:600
ada_add_global_exceptions
static void ada_add_global_exceptions(compiled_regex *preg, std::vector< ada_exc_info > *exceptions)
Definition: ada-lang.c:13709
value
Definition: value.c:169
ada_lookup_name_info::m_encoded_p
bool m_encoded_p
Definition: symtab.h:124
find_frame_sal
symtab_and_line find_frame_sal(frame_info *frame)
Definition: frame.c:2487
set_ada_command
static void set_ada_command(const char *arg, int from_tty)
Definition: ada-lang.c:14551
using_direct::next
struct using_direct * next
Definition: namespace.h:98
decode_constrained_packed_array
static struct value * decode_constrained_packed_array(struct value *)
Definition: ada-lang.c:2297
ada_to_fixed_value_create
static struct value * ada_to_fixed_value_create(struct type *, CORE_ADDR, struct value *)
Definition: ada-lang.c:9352
ui_out
Definition: ui-out.h:77
bp_location::address
CORE_ADDR address
Definition: breakpoint.h:427
blockvector
Definition: block.h:112
exp_element::msymbol
struct minimal_symbol * msymbol
Definition: expression.h:66
ada_scan_number
int ada_scan_number(const char str[], int k, LONGEST *R, int *new_k)
Definition: ada-lang.c:7123
max_of_size
static LONGEST max_of_size(int size)
Definition: ada-lang.c:755
print_recreate_thread
void print_recreate_thread(struct breakpoint *b, struct ui_file *fp)
Definition: breakpoint.c:15093
ada_discrete_type_low_bound
LONGEST ada_discrete_type_low_bound(struct type *type)
Definition: ada-lang.c:821
ada_is_array_type
static int ada_is_array_type(struct type *type)
Definition: ada-lang.c:1917
ada_sniff_from_mangled_name
static int ada_sniff_from_mangled_name(const char *mangled, char **out)
Definition: ada-lang.c:1474
bpstats::breakpoint_at
struct breakpoint * breakpoint_at
Definition: breakpoint.h:1122
value_ref
struct value * value_ref(struct value *arg1, enum type_code refcode)
Definition: valops.c:1521
PREC_ABOVE_COMMA
Definition: parser-defs.h:296
pos_atr
static LONGEST pos_atr(struct value *)
Definition: ada-lang.c:9412
SYMBOL_OBJFILE_OWNED
#define SYMBOL_OBJFILE_OWNED(symbol)
Definition: symtab.h:1156
ada_is_fixed_point_type
int ada_is_fixed_point_type(struct type *type)
Definition: ada-lang.c:11672
LA_PRINT_TYPE
#define LA_PRINT_TYPE(type, varstring, stream, show, level, flags)
Definition: language.h:518
xrealloc
PTR xrealloc(PTR ptr, size_t size)
Definition: common-utils.c:52
ada_resolve_function
static int ada_resolve_function(struct block_symbol *, int, struct value **, int, const char *, struct type *)
ada_primitive_type_long
Definition: ada-lang.c:14226
objfile
Definition: objfiles.h:286
ada_which_variant_applies
int ada_which_variant_applies(struct type *var_type, struct type *outer_type, const gdb_byte *outer_valaddr)
Definition: ada-lang.c:7855
symtab_and_line
Definition: symtab.h:1746
ada_catchpoint_location_ops
static const struct bp_location_ops ada_catchpoint_location_ops
Definition: ada-lang.c:12501
TYPE_CODE_PTR
Definition: gdbtypes.h:84
print_stop_action
print_stop_action
Definition: breakpoint.h:498
ada_init_symbol_cache
static void ada_init_symbol_cache(struct ada_symbol_cache *sym_cache)
Definition: ada-lang.c:4641
ada_is_ignored_field
int ada_is_ignored_field(struct type *type, int field_num)
Definition: ada-lang.c:6623
numeric_type_p
static int numeric_type_p(struct type *)
Definition: ada-lang.c:4156
exception_support_info::unhandled_exception_name_addr
ada_unhandled_exception_name_addr_ftype * unhandled_exception_name_addr
Definition: ada-lang.c:12047
warning_limit
static int warning_limit
Definition: ada-lang.c:334
COMPUNIT_BLOCKVECTOR
#define COMPUNIT_BLOCKVECTOR(cust)
Definition: symtab.h:1465
fixup_symbol_section
struct symbol * fixup_symbol_section(struct symbol *sym, struct objfile *objfile)
Definition: symtab.c:1718
assign_component
static void assign_component(struct value *container, struct value *lhs, LONGEST index, struct expression *exp, int *pos)
Definition: ada-lang.c:9990
ada_dump_subexp_body
static int ada_dump_subexp_body(struct expression *exp, struct ui_file *stream, int elt)
Definition: ada-lang.c:13981
gdb_byte
bfd_byte gdb_byte
Definition: common-types.h:38
allocate_location_exception
static struct bp_location * allocate_location_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *self)
Definition: ada-lang.c:12585
ada_array_arity
int ada_array_arity(struct type *type)
Definition: ada-lang.c:2967
VARIABLES_DOMAIN
Definition: symtab.h:777
c_watch_location_expression
gdb::unique_xmalloc_ptr< char > c_watch_location_expression(struct type *type, CORE_ADDR addr)
Definition: c-lang.c:712
ada_variant_discrim_name
const char * ada_variant_discrim_name(struct type *type0)
Definition: ada-lang.c:7069
aggregate_assign_positional
static void aggregate_assign_positional(struct value *, struct value *, struct expression *, int *, LONGEST *, int *, int, LONGEST, LONGEST)
Definition: ada-lang.c:10114
ada_coerce_ref
static struct value * ada_coerce_ref(struct value *)
Definition: ada-lang.c:7943
ada_la_decode
static char * ada_la_decode(const char *encoded, int options)
Definition: ada-lang.c:1466
MSYMBOL_TYPE
#define MSYMBOL_TYPE(msymbol)
Definition: symtab.h:680
help_list
void help_list(struct cmd_list_element *list, const char *cmdtype, enum command_class theclass, struct ui_file *stream)
Definition: cli-decode.c:1071
default_exception_support_info
static const struct exception_support_info default_exception_support_info
Definition: ada-lang.c:12057
ada_update_initial_language
enum language ada_update_initial_language(enum language lang)
Definition: ada-lang.c:902
discard_cleanups
void discard_cleanups(struct cleanup *old_chain)
Definition: cleanups.c:212
exp_element
Definition: expression.h:62
strcmp_iw_ordered
int strcmp_iw_ordered(const char *string1, const char *string2)
Definition: utils.c:2561
ALL_MSYMBOLS
#define ALL_MSYMBOLS(objfile, m)
Definition: objfiles.h:626
add_nonlocal_symbols
static void add_nonlocal_symbols(struct obstack *obstackp, const lookup_name_info &lookup_name, domain_enum domain, int global)
Definition: ada-lang.c:5667
ada_completer_word_break_characters
static const char ada_completer_word_break_characters[]
Definition: ada-lang.c:322
ada_catch_exception
Definition: ada-lang.h:109
compare_names_with_case
static int compare_names_with_case(const char *string1, const char *string2, enum case_sensitivity casing)
Definition: ada-lang.c:5571
TYPE_TARGET_TYPE
#define TYPE_TARGET_TYPE(thistype)
Definition: gdbtypes.h:1226
macro_expansion_no
Definition: language.h:103
print_one_catch_exception
static void print_one_catch_exception(struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:12931
source.h
ada_lookup_name_info::matches
bool matches(const char *symbol_search_name, symbol_name_match_type match_type, completion_match_result *comp_match_res) const
Definition: ada-lang.c:6380
value_fetch_lazy
void value_fetch_lazy(struct value *val)
Definition: value.c:3860
completion_match_result::set_match
void set_match(const char *m, const char *m_for_lcd=NULL)
Definition: completer.h:215
builtin_type::builtin_double
struct type * builtin_double
Definition: gdbtypes.h:1511
value_neg
struct value * value_neg(struct value *arg1)
Definition: valarith.c:1640
ada_add_block_renamings
static int ada_add_block_renamings(struct obstack *obstackp, const struct block *block, const lookup_name_info &lookup_name, domain_enum domain)
Definition: ada-lang.c:5515
ada_aligned_type
struct type * ada_aligned_type(struct type *type)
Definition: ada-lang.c:9584
desc_data
static struct value * desc_data(struct value *)
Definition: ada-lang.c:1799
cond_offset_target
static CORE_ADDR cond_offset_target(CORE_ADDR address, long offset)
Definition: ada-lang.c:712
print_subexp_standard
void print_subexp_standard(struct expression *exp, int *pos, struct ui_file *stream, enum precedence prec)
Definition: expprint.c:58
ada_get_tsd_from_tag
static struct value * ada_get_tsd_from_tag(struct value *tag)
Definition: ada-lang.c:6861
gdb::function_view
Definition: function-view.h:177
gdb_stderr
#define gdb_stderr
Definition: utils.h:344
catch_assert_command
static void catch_assert_command(const char *arg_entry, int from_tty, struct cmd_list_element *command)
Definition: ada-lang.c:13502
XCNEW
#define XCNEW(T)
Definition: poison.h:121
gdbcore.h
print_subexp
void print_subexp(struct expression *exp, int *pos, struct ui_file *stream, enum precedence prec)
Definition: expprint.c:49
async_reason_lookup
const char * async_reason_lookup(enum async_reply_reason reason)
Definition: mi-common.c:49
ada_pspace_data_handle
static const struct program_space_data * ada_pspace_data_handle
Definition: ada-lang.c:450
lookup_name_info::name
const std::string & name() const
Definition: symtab.h:196
exception_support_info::catch_handlers_sym
const char * catch_handlers_sym
Definition: ada-lang.c:12041
xsnprintf
int xsnprintf(char *str, size_t size, const char *format,...)
Definition: common-utils.c:134
ADA_OPERATORS
#define ADA_OPERATORS
Definition: ada-lang.c:13840
ADA_SUBPROGRAM_RENAMING
Definition: ada-lang.h:101
parse_and_eval_address
CORE_ADDR parse_and_eval_address(const char *exp)
Definition: eval.c:101
to_static_fixed_type
static struct type * to_static_fixed_type(struct type *)
Definition: ada-lang.c:9237
find_entry
static struct cache_entry ** find_entry(const char *name, domain_enum domain)
Definition: ada-lang.c:4689
block_static_block
const struct block * block_static_block(const struct block *block)
Definition: block.c:364
TYPE_CODE
#define TYPE_CODE(thistype)
Definition: gdbtypes.h:1238
general_symbol_info
Definition: symtab.h:376
TYPE_INDEX_TYPE
#define TYPE_INDEX_TYPE(type)
Definition: gdbtypes.h:1242
maint_show_ada_cmdlist
static struct cmd_list_element * maint_show_ada_cmdlist
Definition: ada-lang.c:351
ada_is_non_standard_exception_sym
static int ada_is_non_standard_exception_sym(struct symbol *sym)
Definition: ada-lang.c:13540
error_call_unknown_return_type
void error_call_unknown_return_type(const char *func_name)
Definition: infcall.c:346
add_catch_command
void add_catch_command(const char *name, const char *docstring, cmd_const_sfunc_ftype *sfunc, completer_ftype *completer, void *user_data_catch, void *user_data_tcatch)
Definition: breakpoint.c:15317
resolve_dynamic_type
struct type * resolve_dynamic_type(struct type *type, const gdb_byte *valaddr, CORE_ADDR addr)
Definition: gdbtypes.c:2317
ui_out::field_int
void field_int(const char *fldname, int value)
Definition: ui-out.c:486
print_it_catch_exception_unhandled
static enum print_stop_action print_it_catch_exception_unhandled(bpstat bs)
Definition: ada-lang.c:12971
bp_location::shlib_disabled
bool shlib_disabled
Definition: breakpoint.h:382
symbol_name_match_type::SEARCH_NAME
precedence
precedence
Definition: parser-defs.h:294
c-lang.h
value_of_variable
struct value * value_of_variable(struct symbol *var, const struct block *b)
Definition: valops.c:1296
desc_index_type
static struct type * desc_index_type(struct type *, int)
Definition: ada-lang.c:1876
ada_index_struct_field
static struct value * ada_index_struct_field(int, struct value *, int, struct type *)
Definition: ada-lang.c:7517
ada_catch_assert
Definition: ada-lang.h:111
TYPE_FIXED_INSTANCE
#define TYPE_FIXED_INSTANCE(t)
Definition: gdbtypes.h:264
inferior_ptid
ptid_t inferior_ptid
Definition: infcmd.c:94
PREC_BITWISE_IOR
Definition: parser-defs.h:297
is_scalar_type
int is_scalar_type(struct type *type)
Definition: gdbtypes.c:3053
bound_minimal_symbol::minsym
struct minimal_symbol * minsym
Definition: minsyms.h:34
replace_operator_with_call
static void replace_operator_with_call(expression_up *, int, int, int, struct symbol *, const struct block *)
Definition: ada-lang.c:4122
ada_type_name
const char * ada_type_name(struct type *type)
Definition: ada-lang.c:8151
maint_set_ada_cmd
static void maint_set_ada_cmd(const char *args, int from_tty)
Definition: ada-lang.c:356
ada_value_ptr_subscript
static struct value * ada_value_ptr_subscript(struct value *arr, int arity, struct value **ind)
Definition: ada-lang.c:2872
gdbarch_long_long_bit
int gdbarch_long_long_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1613
ada_clear_symbol_cache
static void ada_clear_symbol_cache(void)
Definition: ada-lang.c:4676
block_gdbarch
struct gdbarch * block_gdbarch(const struct block *block)
Definition: block.c:60
ada_get_tsd_type
static struct type * ada_get_tsd_type(struct inferior *inf)
Definition: ada-lang.c:6846
ada_parse
int ada_parse(struct parser_state *par_state)
Definition: ada-exp.c:2698
ada_catchpoint_location_dtor
static void ada_catchpoint_location_dtor(struct bp_location *bl)
Definition: ada-lang.c:12492
ada_exc_info::operator<
bool operator<(const ada_exc_info &) const
Definition: ada-lang.c:13567
type_print_options
Definition: typeprint.h:41
ada_coerce_to_simple_array
struct value * ada_coerce_to_simple_array(struct value *arr)
Definition: ada-lang.c:2080
get_user_print_options
void get_user_print_options(struct value_print_options *opts)
Definition: valprint.c:120
offset
int offset
Definition: agent.c:65
add_setshow_boolean_cmd
void add_setshow_boolean_cmd(const char *name, enum command_class theclass, int *var, const char *set_doc, const char *show_doc, const char *help_doc, cmd_const_sfunc_ftype *set_func, show_value_ftype *show_func, struct cmd_list_element **set_list, struct cmd_list_element **show_list)
Definition: cli-decode.c:569
gdb_vecs.h
desc_arity
static int desc_arity(struct type *)
Definition: ada-lang.c:1890
code
int code
Definition: ser-unix.c:239
ada_opname_table
const struct ada_opname_map ada_opname_table[]
Definition: ada-lang.c:955
value_less
int value_less(struct value *arg1, struct value *arg2)
Definition: valarith.c:1566
PREC_BITWISE_AND
Definition: parser-defs.h:297
ada_is_variant_part
int ada_is_variant_part(struct type *type, int field_num)
Definition: ada-lang.c:7029
ada_identical_enum_types_p
static int ada_identical_enum_types_p(struct type *type1, struct type *type2)
Definition: ada-lang.c:5005
TYPE_NFIELDS
#define TYPE_NFIELDS(thistype)
Definition: gdbtypes.h:1239
ada_exception_support_info_sniffer
static void ada_exception_support_info_sniffer(void)
Definition: ada-lang.c:12139
ada_exception_catchpoint_kind
ada_exception_catchpoint_kind
Definition: ada-lang.h:107
ada_exception_name_addr_1
static CORE_ADDR ada_exception_name_addr_1(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:12330
buffer
Definition: buffer.h:23
general_symbol_info::ada_mangled
unsigned int ada_mangled
Definition: symtab.h:437
check_status_catch_assert
static void check_status_catch_assert(bpstat bs)
Definition: ada-lang.c:13013
gdbarch_float_bit
int gdbarch_float_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1680
evaluate_subexp
struct value * evaluate_subexp(struct type *expect_type, struct expression *exp, int *pos, enum noside noside)
Definition: eval.c:69
ada_value_ind
struct value * ada_value_ind(struct value *val0)
Definition: ada-lang.c:7929
ADA_OBJECT_RENAMING
Definition: ada-lang.h:90
ADA_EXCEPTION_RENAMING
Definition: ada-lang.h:94
SYMBOL_LANGUAGE
#define SYMBOL_LANGUAGE(symbol)
Definition: symtab.h:469
ada_catch_exception_unhandled
Definition: ada-lang.h:110
exp_opcode
exp_opcode
Definition: expression.h:42
ada_promote_array_of_integrals
static struct value * ada_promote_array_of_integrals(struct type *type, struct value *val)
Definition: ada-lang.c:9786
print_one_catch_handlers
static void print_one_catch_handlers(struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:13071
is_nondebugging_type
static int is_nondebugging_type(struct type *type)
Definition: ada-lang.c:4990
ada_value_tag
struct value * ada_value_tag(struct value *val)
Definition: ada-lang.c:6707
symbol_matches_domain
int symbol_matches_domain(enum language symbol_language, domain_enum symbol_domain, domain_enum domain)
Definition: symtab.c:2700
completion_match_result::match
completion_match match
Definition: completer.h:208
find_frame_funname
gdb::unique_xmalloc_ptr< char > find_frame_funname(struct frame_info *frame, enum language *funlang, struct symbol **funcp)
Definition: stack.c:1039
TYPE_CODE_INTERNAL_FUNCTION
Definition: gdbtypes.h:178
VAR_DOMAIN
Definition: symtab.h:739
string_printf
std::string string_printf(const char *fmt,...)
Definition: common-utils.c:150
exp_element::objfile
struct objfile * objfile
Definition: expression.h:75
ada_lookup_symbol
struct block_symbol ada_lookup_symbol(const char *name, const struct block *block0, domain_enum domain, int *is_a_field_of_this)
Definition: ada-lang.c:5933
value_free_to_mark
void value_free_to_mark(const struct value *mark)
Definition: value.c:1641
mst_solib_trampoline
Definition: symtab.h:597
evaluate_subexp_standard
struct value * evaluate_subexp_standard(struct type *expect_type, struct expression *exp, int *pos, enum noside noside)
Definition: eval.c:1240
value.h
value_binop
struct value * value_binop(struct value *arg1, struct value *arg2, enum exp_opcode op)
Definition: valarith.c:1379
attribute_names
static const char * attribute_names[]
Definition: ada-lang.c:9383
block_iterator
Definition: block.h:197
ada_printstr
void ada_printstr(struct ui_file *, struct type *, const gdb_byte *, unsigned int, const char *, int, const struct value_print_options *)
Definition: ada-valprint.c:522
ada_value_slice_from_ptr
static struct value * ada_value_slice_from_ptr(struct value *array_ptr, struct type *type, int low, int high)
Definition: ada-lang.c:2906
TYPE_TAG_NAME
#define TYPE_TAG_NAME(type)
Definition: gdbtypes.h:1225
gdbarch::data
void ** data
Definition: gdbarch.c:148
exp_element::longconst
LONGEST longconst
Definition: expression.h:67
ada_lookup_simple_minsym
struct bound_minimal_symbol ada_lookup_simple_minsym(const char *name)
Definition: ada-lang.c:4945
ada_array_element_type
struct type * ada_array_element_type(struct type *type, int nindices)
Definition: ada-lang.c:2995
grow_vect
void * grow_vect(void *vect, size_t *size, size_t min_size, int element_size)
Definition: ada-lang.c:581
operator_length_standard
void operator_length_standard(const struct expression *expr, int endpos, int *oplenp, int *argsp)
Definition: parse.c:837
TYPE_STUB
#define TYPE_STUB(t)
Definition: gdbtypes.h:217
ada_is_modular_type
int ada_is_modular_type(struct type *type)
Definition: ada-lang.c:11955
completion_list_add_name
void completion_list_add_name(completion_tracker &tracker, language symbol_language, const char *symname, const lookup_name_info &lookup_name, const char *text, const char *word)
Definition: symtab.c:4717
op_name_standard
const char * op_name_standard(enum exp_opcode opcode)
Definition: expprint.c:695
gdb::byte_vector
gdb::def_vector< gdb_byte > byte_vector
Definition: byte-vector.h:58
is_name_suffix
static int is_name_suffix(const char *)
Definition: ada-lang.c:6017
ada_free_objfile_observer
static void ada_free_objfile_observer(struct objfile *objfile)
Definition: ada-lang.c:14625
current_inferior
struct inferior * current_inferior(void)
Definition: inferior.c:58
is_thin_pntr
static int is_thin_pntr(struct type *type)
Definition: ada-lang.c:1607
get_selected_block
const struct block * get_selected_block(CORE_ADDR *addr_in_block)
Definition: stack.c:2216
bp_location::ops
const bp_location_ops * ops
Definition: breakpoint.h:327
full_match
static bool full_match(const char *sym_name, const char *search_name)
Definition: ada-lang.c:6250
ada_exception_breakpoint_ops
static const struct breakpoint_ops * ada_exception_breakpoint_ops(enum ada_exception_catchpoint_kind ex)
Definition: ada-lang.c:13245
PREC_ASSIGN
Definition: parser-defs.h:296
ada_decode_symbol
const char * ada_decode_symbol(const struct general_symbol_info *arg)
Definition: ada-lang.c:1430
get_dyn_prop
struct dynamic_prop * get_dyn_prop(enum dynamic_prop_node_kind prop_kind, const struct type *type)
Definition: gdbtypes.c:2329
SYMBOL_NATURAL_NAME
#define SYMBOL_NATURAL_NAME(symbol)
Definition: symtab.h:513
coerce_for_assign
static struct value * coerce_for_assign(struct type *type, struct value *val)
Definition: ada-lang.c:9824
set_value_bitsize
void set_value_bitsize(struct value *value, LONGEST bit)
Definition: value.c:1133
re_comp
EXTERN_C char * re_comp(const char *)
fat_pntr_data_bitsize
static int fat_pntr_data_bitsize(struct type *)
Definition: ada-lang.c:1826
current_program_space
struct program_space * current_program_space
Definition: progspace.c:35
add_defn_to_vec
static void add_defn_to_vec(struct obstack *, struct symbol *, const struct block *)
Definition: ada-lang.c:4880
thin_data_pntr
static struct value * thin_data_pntr(struct value *val)
Definition: ada-lang.c:1639
gdbtypes.h
typeprint.h
ada_enum_name
const char * ada_enum_name(const char *name)
Definition: ada-lang.c:9613
parse_and_eval
struct value * parse_and_eval(const char *exp)
Definition: eval.c:119
gdbarch_bits_big_endian
int gdbarch_bits_big_endian(struct gdbarch *gdbarch)
Definition: gdbarch.c:1545
ULONGEST
unsigned long long ULONGEST
Definition: common-types.h:53
ADA_NOT_RENAMING
Definition: ada-lang.h:86
exception_support_info::catch_exception_sym
const char * catch_exception_sym
Definition: ada-lang.c:12029
ada_val_print
void ada_val_print(struct type *, int, CORE_ADDR, struct ui_file *, int, struct value *, const struct value_print_options *)
Definition: ada-valprint.c:1165
ada_exception_catchpoint_cond_string
static char * ada_exception_catchpoint_cond_string(const char *excep_string, enum ada_exception_catchpoint_kind ex)
Definition: ada-lang.c:13277
STATIC_BLOCK
Definition: defs.h:687
value_pointer
static CORE_ADDR value_pointer(struct value *value, struct type *type)
Definition: ada-lang.c:4560
field_name
static PyObject * field_name(struct type *type, int field)
Definition: py-type.c:267
call_function_by_hand
struct value * call_function_by_hand(struct value *function, type *default_return_type, int nargs, struct value **args)
Definition: infcall.c:690
language
language
Definition: defs.h:203
initialize_breakpoint_ops
void initialize_breakpoint_ops(void)
Definition: breakpoint.c:15414
is_unchecked_variant
static int is_unchecked_variant(struct type *var_type, struct type *outer_type)
Definition: ada-lang.c:7841
value_allocate_space_in_inferior
struct value * value_allocate_space_in_inferior(int len)
Definition: valops.c:185
value_slice
struct value * value_slice(struct value *array, int lowbound, int length)
Definition: valops.c:3778
bound_name
static const char * bound_name[]
Definition: ada-lang.c:1571
expression::gdbarch
struct gdbarch * gdbarch
Definition: expression.h:82
is_dynamic_type
int is_dynamic_type(struct type *type)
Definition: gdbtypes.c:1976
ada_exception_sal
static struct symtab_and_line ada_exception_sal(enum ada_exception_catchpoint_kind ex, char *excep_string, const char **addr_string, const struct breakpoint_ops **ops)
Definition: ada-lang.c:13344
ada_is_aligner_type
int ada_is_aligner_type(struct type *type)
Definition: ada-lang.c:9520
observer_attach_new_objfile
struct observer * observer_attach_new_objfile(observer_new_objfile_ftype *f)
value_primitive_field
struct value * value_primitive_field(struct value *arg1, LONGEST offset, int fieldno, struct type *arg_type)
Definition: value.c:3028
is_dynamic_field
static int is_dynamic_field(struct type *, int)
Definition: ada-lang.c:8287
completion_tracker
Definition: completer.h:310
bpstats::stop
char stop
Definition: breakpoint.h:1134
move_bits
static void move_bits(gdb_byte *, int, const gdb_byte *, int, int, int)
Definition: ada-lang.c:2669
value_type
struct type * value_type(const struct value *value)
Definition: value.c:1095
print_mention_catch_exception
static void print_mention_catch_exception(struct breakpoint *b)
Definition: ada-lang.c:12937
PREC_SUFFIX
Definition: parser-defs.h:299
ada_value_binop
static struct value * ada_value_binop(struct value *arg1, struct value *arg2, enum exp_opcode op)
Definition: ada-lang.c:9866
TYPE_ARRAY_LOWER_BOUND_VALUE
#define TYPE_ARRAY_LOWER_BOUND_VALUE(arraytype)
Definition: gdbtypes.h:1294
TYPE_ALLOC
#define TYPE_ALLOC(t, size)
Definition: gdbtypes.h:1652
range_type
range_type
Definition: expression.h:161
SYMBOL_TYPE
#define SYMBOL_TYPE(symbol)
Definition: symtab.h:1161
assign_aggregate
static struct value * assign_aggregate(struct value *, struct value *, struct expression *, int *, enum noside)
Definition: ada-lang.c:10029
language_arch_info
Definition: language.h:109
L
Definition: ia64-tdep.c:84
ada_ensure_varsize_limit
void ada_ensure_varsize_limit(const struct type *type)
Definition: ada-lang.c:747
symbol
Definition: symtab.h:1049
ada_convert_actual
struct value * ada_convert_actual(struct value *actual, struct type *formal_type0)
Definition: ada-lang.c:4497
fat_pntr_bounds_bitsize
static int fat_pntr_bounds_bitsize(struct type *)
Definition: ada-lang.c:1760
all_commands
Definition: command.h:39
ada_find_renaming_symbol
struct symbol * ada_find_renaming_symbol(struct symbol *name_sym, const struct block *block)
Definition: ada-lang.c:8037
ada_pspace_data_cleanup
static void ada_pspace_data_cleanup(struct program_space *pspace, void *data)
Definition: ada-lang.c:476
value_as_address
CORE_ADDR value_as_address(struct value *val)
Definition: value.c:2762
gdbarch_float_format
const struct floatformat ** gdbarch_float_format(struct gdbarch *gdbarch)
Definition: gdbarch.c:1697
LA_VALUE_PRINT
#define LA_VALUE_PRINT(val, stream, options)
Definition: language.h:524
bp_location::gdbarch
struct gdbarch * gdbarch
Definition: breakpoint.h:413
ada_inferior_data
Definition: ada-lang.c:378
compiled_regex
Definition: gdb_regex.h:35
bpstats
Definition: breakpoint.h:1087
LOC_OPTIMIZED_OUT
Definition: symtab.h:888
value_contents_copy_raw
void value_contents_copy_raw(struct value *dst, LONGEST dst_offset, struct value *src, LONGEST src_offset, LONGEST length)
Definition: value.c:1326
PREC_REPEAT
Definition: parser-defs.h:298
quick_symbol_functions::map_matching_symbols
void(* map_matching_symbols)(struct objfile *, const char *name, domain_enum domain, int global, int(*callback)(struct block *, struct symbol *, void *), void *data, symbol_name_match_type match, symbol_compare_ftype *ordered_compare)
Definition: symfile.h:228
re_set_catch_exception_unhandled
static void re_set_catch_exception_unhandled(struct breakpoint *b)
Definition: ada-lang.c:12959
num_component_specs
static int num_component_specs(struct expression *exp, int pc)
Definition: ada-lang.c:9960
make_array_descriptor
static struct value * make_array_descriptor(struct type *, struct value *)
Definition: ada-lang.c:4581
num_defns_collected
static int num_defns_collected(struct obstack *)
Definition: ada-lang.c:4921
ada_to_fixed_value
struct value * ada_to_fixed_value(struct value *val)
Definition: ada-lang.c:9368
value_contents_raw
gdb_byte * value_contents_raw(struct value *value)
Definition: value.c:1158
annotate_catchpoint
void annotate_catchpoint(int num)
Definition: annotate.c:87
symtab_and_line::line
int line
Definition: symtab.h:1757
ada_is_parent_field
int ada_is_parent_field(struct type *type, int field_num)
Definition: ada-lang.c:6986
cast_to_fixed
static struct value * cast_to_fixed(struct type *type, struct value *arg)
Definition: ada-lang.c:9739
breakpoint_ops
Definition: breakpoint.h:520
is_suffix
static int is_suffix(const char *str, const char *suffix)
Definition: ada-lang.c:658
ada_iterate_over_symbols
static void ada_iterate_over_symbols(const struct block *block, const lookup_name_info &name, domain_enum domain, gdb::function_view< symbol_found_callback_ftype > callback)
Definition: ada-lang.c:5882
type_name_no_tag
const char * type_name_no_tag(const struct type *type)
Definition: gdbtypes.c:1466
allocate_location_catch_exception
static struct bp_location * allocate_location_catch_exception(struct breakpoint *self)
Definition: ada-lang.c:12907
TYPE_LENGTH
#define TYPE_LENGTH(thistype)
Definition: gdbtypes.h:1235
minimal_symbol
Definition: symtab.h:623
ada_lookup_encoded_symbol
void ada_lookup_encoded_symbol(const char *name, const struct block *block, domain_enum domain, struct block_symbol *info)
Definition: ada-lang.c:5910
ada_opname_map::encoded
const char * encoded
Definition: ada-lang.h:73
bound_minimal_symbol::objfile
struct objfile * objfile
Definition: minsyms.h:39
PREC_SHIFT
Definition: parser-defs.h:298
language_lookup_primitive_type
struct type * language_lookup_primitive_type(const struct language_defn *la, struct gdbarch *gdbarch, const char *name)
Definition: language.c:1025
HOST_CHAR_BIT
#define HOST_CHAR_BIT
Definition: host-defs.h:40
init_ada_exception_breakpoint
void init_ada_exception_breakpoint(struct breakpoint *b, struct gdbarch *gdbarch, struct symtab_and_line sal, const char *addr_string, const struct breakpoint_ops *ops, int tempflag, int enabled, int from_tty)
Definition: breakpoint.c:11391
lookup_cached_symbol
static int lookup_cached_symbol(const char *name, domain_enum domain, struct symbol **sym, const struct block **block)
Definition: ada-lang.c:4711
value::address
CORE_ADDR address
Definition: value.c:208
ada_lookup_name_info::lookup_name
const std::string & lookup_name() const
Definition: symtab.h:100
catch_exception_breakpoint_ops
static struct breakpoint_ops catch_exception_breakpoint_ops
Definition: ada-lang.c:12948
ada_catchpoint_location::ada_catchpoint_location
ada_catchpoint_location(const bp_location_ops *ops, breakpoint *owner)
Definition: ada-lang.c:12478
ada_unqualified_name
static const char * ada_unqualified_name(const char *decoded_name)
Definition: ada-lang.c:527
class_maintenance
Definition: command.h:43
catch_ada_handlers_command
static void catch_ada_handlers_command(const char *arg_entry, int from_tty, struct cmd_list_element *command)
Definition: ada-lang.c:13447
to_fixed_record_type
static struct type * to_fixed_record_type(struct type *type0, const gdb_byte *valaddr, CORE_ADDR address, struct value *dval)
Definition: ada-lang.c:8765
ada_is_direct_array_type
static int ada_is_direct_array_type(struct type *)
Definition: ada-lang.c:1904
bp_location::owner
breakpoint * owner
Definition: breakpoint.h:341
annotate.h
re_set_catch_assert
static void re_set_catch_assert(struct breakpoint *b)
Definition: ada-lang.c:13007
block_depth
static int block_depth(struct block *)
Definition: symmisc.c:968
desc_bounds
static struct value * desc_bounds(struct value *)
Definition: ada-lang.c:1696
vwarning
void void vwarning(const char *fmt, va_list args) ATTRIBUTE_PRINTF(1
ada_remove_po_subprogram_suffix
static void ada_remove_po_subprogram_suffix(const char *encoded, int *len)
Definition: ada-lang.c:1119
language_unknown
Definition: defs.h:205
write_memory_with_notification
void write_memory_with_notification(CORE_ADDR memaddr, const bfd_byte *myaddr, ssize_t len)
Definition: corefile.c:407
value_true
int value_true(struct value *val)
Definition: language.c:426
ALL_OBJFILES
#define ALL_OBJFILES(obj)
Definition: objfiles.h:582
auto_obstack
Definition: gdb_obstack.h:67
LANG_MAGIC
#define LANG_MAGIC
Definition: language.h:438
QUIT
#define QUIT
Definition: defs.h:179
ada_inferior_exit
static void ada_inferior_exit(struct inferior *inf)
Definition: ada-lang.c:433
write_memory
void write_memory(CORE_ADDR memaddr, const bfd_byte *myaddr, ssize_t len)
Definition: corefile.c:394
value_tag_from_contents_and_address
static struct value * value_tag_from_contents_and_address(struct type *type, const gdb_byte *valaddr, CORE_ADDR address)
Definition: ada-lang.c:6717
gdbarch_long_double_bit
int gdbarch_long_double_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1746
sym_fns::qf
const struct quick_symbol_functions * qf
Definition: symfile.h:369
cache_entry::name
const char * name
Definition: ada-lang.c:284
ada_printchar
void ada_printchar(int, struct type *, struct ui_file *)
Definition: ada-valprint.c:348
valprint.h
symbol_name_match_type::FULL
value_address
CORE_ADDR value_address(const struct value *value)
Definition: value.c:1529
desc_data_target_type
static struct type * desc_data_target_type(struct type *)
Definition: ada-lang.c:1776
gdbarch_short_bit
int gdbarch_short_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1562
TYPE_DESCRIPTIVE_TYPE
#define TYPE_DESCRIPTIVE_TYPE(thistype)
Definition: gdbtypes.h:1326
ADA_PACKAGE_RENAMING
Definition: ada-lang.h:97
resolve_subexp
static struct value * resolve_subexp(expression_up *, int *, int, struct type *)
Definition: ada-lang.c:3263
not_lval
Definition: defs.h:381
language_arch_info::primitive_type_vector
struct type ** primitive_type_vector
Definition: language.h:115
ada_primitive_type_double
Definition: ada-lang.c:14230
lookup_minimal_symbol
struct bound_minimal_symbol lookup_minimal_symbol(const char *name, const char *sfile, struct objfile *objf)
Definition: minsyms.c:311
using_direct::declaration
const char * declaration
Definition: namespace.h:96
xcalloc
PTR xcalloc(size_t number, size_t size)
Definition: common-utils.c:72
print_mention_exception
static void print_mention_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:12817
symbol_symtab
struct symtab * symbol_symtab(const struct symbol *symbol)
Definition: symtab.c:5803
dynamic_template_type
static struct type * dynamic_template_type(struct type *type)
Definition: ada-lang.c:8265
discrete_type_p
static int discrete_type_p(struct type *)
Definition: ada-lang.c:4223
lookup_name_info
Definition: symtab.h:179
stack.h
class_obscure
Definition: command.h:43
maintenance_show_cmdlist
struct cmd_list_element * maintenance_show_cmdlist
Definition: maint.c:635
get_array_bounds
int get_array_bounds(struct type *type, LONGEST *low_bound, LONGEST *high_bound)
Definition: gdbtypes.c:1056
ada_inferior_data_cleanup
static void ada_inferior_data_cleanup(struct inferior *inf, void *arg)
Definition: ada-lang.c:397
set_value_bitpos
void set_value_bitpos(struct value *value, LONGEST bit)
Definition: value.c:1122
TYPE_ARRAY_UPPER_BOUND_VALUE
#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype)
Definition: gdbtypes.h:1291
target_read_string
int target_read_string(CORE_ADDR memaddr, char **string, int len, int *errnop)
Definition: target.c:907
print_one_exception
static void print_one_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:12757
lookup_symbol_in_language
struct block_symbol lookup_symbol_in_language(const char *name, const struct block *block, const domain_enum domain, enum language lang, struct field_of_this_result *is_a_field_of_this)
Definition: symtab.c:1877
gdbcmd.h
builtin_type::builtin_void
struct type * builtin_void
Definition: gdbtypes.h:1500
has_stack_frames
int has_stack_frames(void)
Definition: frame.c:1609
get_base_type
static struct type * get_base_type(struct type *type)
Definition: ada-lang.c:844
breakpoint_ops::print_one
void(* print_one)(struct breakpoint *, struct bp_location **)
Definition: breakpoint.h:572
case_sensitivity
case_sensitivity
Definition: language.h:90
get_discrete_bounds
int get_discrete_bounds(struct type *type, LONGEST *lowp, LONGEST *highp)
Definition: gdbtypes.c:977
name_matches_regex
static bool name_matches_regex(const char *name, compiled_regex *preg)
Definition: ada-lang.c:13683
ada_operator_check
static int ada_operator_check(struct expression *exp, int pos, int(*objfile_func)(struct objfile *objfile, void *data), void *data)
Definition: ada-lang.c:13891
multiple_symbols_all
const char multiple_symbols_all[]
Definition: symtab.c:238
language_cplus
Definition: defs.h:209
ada_language_defn
const struct language_defn ada_language_defn
error
void error(const char *fmt,...)
Definition: errors.c:38
case_sensitive_off
Definition: language.h:92
size
size_t size
Definition: go32-nat.c:242
breakpoint_ops::re_set
void(* re_set)(struct breakpoint *self)
Definition: breakpoint.h:528
language_c
Definition: defs.h:207
gdbarch_address_to_pointer
void gdbarch_address_to_pointer(struct gdbarch *gdbarch, struct type *type, gdb_byte *buf, CORE_ADDR addr)
Definition: gdbarch.c:2680
set_breakpoint_condition
void set_breakpoint_condition(struct breakpoint *b, const char *exp, int from_tty)
Definition: breakpoint.c:838
ada_scaling_type
static struct type * ada_scaling_type(struct type *type)
Definition: ada-lang.c:11691
resolve
static void resolve(expression_up *expp, int void_context_p)
Definition: ada-lang.c:3242
ALL_BLOCK_SYMBOLS
#define ALL_BLOCK_SYMBOLS(block, iter, sym)
Definition: block.h:310
lookup_pointer_type
struct type * lookup_pointer_type(struct type *type)
Definition: gdbtypes.c:381
dictionary.h
catch_handlers_breakpoint_ops
static struct breakpoint_ops catch_handlers_breakpoint_ops
Definition: ada-lang.c:13090
ada_get_symbol_cache
static struct ada_symbol_cache * ada_get_symbol_cache(struct program_space *pspace)
Definition: ada-lang.c:4660
PREC_LOGICAL_AND
Definition: parser-defs.h:297
symbol_name_match_type::WILD
block.h
ada_typedef_target_type
static struct type * ada_typedef_target_type(struct type *type)
Definition: ada-lang.c:515
throw_error
void throw_error(enum errors error, const char *fmt,...)
Definition: common-exceptions.c:389
LONGEST
long long LONGEST
Definition: common-types.h:52
ada_lookup_symbol_nonlocal
static struct block_symbol ada_lookup_symbol_nonlocal(const struct language_defn *langdef, const char *name, const struct block *block, const domain_enum domain)
Definition: ada-lang.c:5961
ada_primitive_type_natural
Definition: ada-lang.c:14234
ada_lookup_name_info::m_verbatim_p
bool m_verbatim_p
Definition: symtab.h:134
ada_find_any_type_symbol
static struct symbol * ada_find_any_type_symbol(const char *name)
Definition: ada-lang.c:8003
do_cleanups
void do_cleanups(struct cleanup *old_chain)
Definition: cleanups.c:174
sort_remove_dups_ada_exceptions_list
static void sort_remove_dups_ada_exceptions_list(std::vector< ada_exc_info > *exceptions, int skip)
Definition: ada-lang.c:13591
ada_value_assign
static struct value * ada_value_assign(struct value *toval, struct value *fromval)
Definition: ada-lang.c:2737
ada_decoded_op_name
static const char * ada_decoded_op_name(enum exp_opcode)
Definition: ada-lang.c:3219
ada_exceptions_list_1
static std::vector< ada_exc_info > ada_exceptions_list_1(compiled_regex *preg)
Definition: ada-lang.c:13759
check_status_exception
static void check_status_exception(enum ada_exception_catchpoint_kind ex, bpstat bs)
Definition: ada-lang.c:12654
program_space
Definition: progspace.h:137
set_value_component_location
void set_value_component_location(struct value *component, const struct value *whole)
Definition: value.c:1849
ui_out::is_mi_like_p
bool is_mi_like_p()
Definition: ui-out.c:622
SYMBOL_IS_ARGUMENT
#define SYMBOL_IS_ARGUMENT(symbol)
Definition: symtab.h:1157
symfile.h
bp_location
Definition: breakpoint.h:315
symbol_name_match_type
symbol_name_match_type
Definition: symtab.h:52
wild_match
static bool wild_match(const char *name, const char *patn)
Definition: ada-lang.c:6219
bpdisp_text
const char * bpdisp_text(enum bpdisp disp)
Definition: breakpoint.c:314
vec.h
general_symbol_info::demangled_name
const char * demangled_name
Definition: symtab.h:424
ui_out::field_fmt
void field_fmt(const char *fldname, const char *format,...) ATTRIBUTE_PRINTF(3
Definition: ui-out.c:557
ui-out.h
symbol::domain
__extension__ enum domain_enum_tag domain
Definition: symtab.h:1076
fat_pntr_bounds_bitpos
static int fat_pntr_bounds_bitpos(struct type *)
Definition: ada-lang.c:1751
store_unsigned_integer
static void store_unsigned_integer(gdb_byte *addr, int len, enum bfd_endian byte_order, ULONGEST val)
Definition: defs.h:604
modify_field
void modify_field(struct type *type, gdb_byte *addr, LONGEST fieldval, LONGEST bitpos, LONGEST bitsize)
Definition: value.c:3403
gdb_stdout
#define gdb_stdout
Definition: utils.h:340
ada_extensions
static const char * ada_extensions[]
Definition: ada-lang.c:14490
builtin_type::builtin_int
struct type * builtin_int
Definition: gdbtypes.h:1503
compare_names
static int compare_names(const char *string1, const char *string2)
Definition: ada-lang.c:5636
get_var_value
static struct value * get_var_value(const char *name, const char *err_msg)
Definition: ada-lang.c:11797
string_file
Definition: ui-file.h:106
compiled_regex::exec
int exec(const char *string, size_t nmatch, regmatch_t pmatch[], int eflags) const
Definition: gdb_regex.c:45