GDB (xrefs)
/tmp/gdb-7.10/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-2015 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 
57 #include "psymtab.h"
58 #include "value.h"
59 #include "mi/mi-common.h"
60 #include "arch-utils.h"
61 #include "cli/cli-utils.h"
62 
63 /* Define whether or not the C operator '/' truncates towards zero for
64  differently signed operands (truncation direction is undefined in C).
65  Copied from valarith.c. */
66 
67 #ifndef TRUNCATION_TOWARDS_ZERO
68 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
69 #endif
70 
71 static struct type *desc_base_type (struct type *);
72 
73 static struct type *desc_bounds_type (struct type *);
74 
75 static struct value *desc_bounds (struct value *);
76 
77 static int fat_pntr_bounds_bitpos (struct type *);
78 
79 static int fat_pntr_bounds_bitsize (struct type *);
80 
81 static struct type *desc_data_target_type (struct type *);
82 
83 static struct value *desc_data (struct value *);
84 
85 static int fat_pntr_data_bitpos (struct type *);
86 
87 static int fat_pntr_data_bitsize (struct type *);
88 
89 static struct value *desc_one_bound (struct value *, int, int);
90 
91 static int desc_bound_bitpos (struct type *, int, int);
92 
93 static int desc_bound_bitsize (struct type *, int, int);
94 
95 static struct type *desc_index_type (struct type *, int);
96 
97 static int desc_arity (struct type *);
98 
99 static int ada_type_match (struct type *, struct type *, int);
100 
101 static int ada_args_match (struct symbol *, struct value **, int);
102 
103 static int full_match (const char *, const char *);
104 
105 static struct value *make_array_descriptor (struct type *, struct value *);
106 
107 static void ada_add_block_symbols (struct obstack *,
108  const struct block *, const char *,
109  domain_enum, struct objfile *, int);
110 
111 static int is_nonfunction (struct ada_symbol_info *, int);
112 
113 static void add_defn_to_vec (struct obstack *, struct symbol *,
114  const struct block *);
115 
116 static int num_defns_collected (struct obstack *);
117 
118 static struct ada_symbol_info *defns_collected (struct obstack *, int);
119 
120 static struct value *resolve_subexp (struct expression **, int *, int,
121  struct type *);
122 
123 static void replace_operator_with_call (struct expression **, int, int, int,
124  struct symbol *, const struct block *);
125 
126 static int possible_user_operator_p (enum exp_opcode, struct value **);
127 
128 static char *ada_op_name (enum exp_opcode);
129 
130 static const char *ada_decoded_op_name (enum exp_opcode);
131 
132 static int numeric_type_p (struct type *);
133 
134 static int integer_type_p (struct type *);
135 
136 static int scalar_type_p (struct type *);
137 
138 static int discrete_type_p (struct type *);
139 
141  const char **,
142  int *,
143  const char **);
144 
145 static struct symbol *find_old_style_renaming_symbol (const char *,
146  const struct block *);
147 
148 static struct type *ada_lookup_struct_elt_type (struct type *, char *,
149  int, int, int *);
150 
151 static struct value *evaluate_subexp_type (struct expression *, int *);
152 
153 static struct type *ada_find_parallel_type_with_name (struct type *,
154  const char *);
155 
156 static int is_dynamic_field (struct type *, int);
157 
158 static struct type *to_fixed_variant_branch_type (struct type *,
159  const gdb_byte *,
160  CORE_ADDR, struct value *);
161 
162 static struct type *to_fixed_array_type (struct type *, struct value *, int);
163 
164 static struct type *to_fixed_range_type (struct type *, struct value *);
165 
166 static struct type *to_static_fixed_type (struct type *);
167 static struct type *static_unwrap_type (struct type *type);
168 
169 static struct value *unwrap_value (struct value *);
170 
171 static struct type *constrained_packed_array_type (struct type *, long *);
172 
173 static struct type *decode_constrained_packed_array_type (struct type *);
174 
175 static long decode_packed_array_bitsize (struct type *);
176 
177 static struct value *decode_constrained_packed_array (struct value *);
178 
179 static int ada_is_packed_array_type (struct type *);
180 
181 static int ada_is_unconstrained_packed_array_type (struct type *);
182 
183 static struct value *value_subscript_packed (struct value *, int,
184  struct value **);
185 
186 static void move_bits (gdb_byte *, int, const gdb_byte *, int, int, int);
187 
188 static struct value *coerce_unspec_val_to_type (struct value *,
189  struct type *);
190 
191 static struct value *get_var_value (char *, char *);
192 
193 static int lesseq_defined_than (struct symbol *, struct symbol *);
194 
195 static int equiv_types (struct type *, struct type *);
196 
197 static int is_name_suffix (const char *);
198 
199 static int advance_wild_match (const char **, const char *, int);
200 
201 static int wild_match (const char *, const char *);
202 
203 static struct value *ada_coerce_ref (struct value *);
204 
205 static LONGEST pos_atr (struct value *);
206 
207 static struct value *value_pos_atr (struct type *, struct value *);
208 
209 static struct value *value_val_atr (struct type *, struct value *);
210 
211 static struct symbol *standard_lookup (const char *, const struct block *,
212  domain_enum);
213 
214 static struct value *ada_search_struct_field (char *, struct value *, int,
215  struct type *);
216 
217 static struct value *ada_value_primitive_field (struct value *, int, int,
218  struct type *);
219 
220 static int find_struct_field (const char *, struct type *, int,
221  struct type **, int *, int *, int *, int *);
222 
223 static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
224  struct value *);
225 
226 static int ada_resolve_function (struct ada_symbol_info *, int,
227  struct value **, int, const char *,
228  struct type *);
229 
230 static int ada_is_direct_array_type (struct type *);
231 
232 static void ada_language_arch_info (struct gdbarch *,
233  struct language_arch_info *);
234 
235 static struct value *ada_index_struct_field (int, struct value *, int,
236  struct type *);
237 
238 static struct value *assign_aggregate (struct value *, struct value *,
239  struct expression *,
240  int *, enum noside);
241 
242 static void aggregate_assign_from_choices (struct value *, struct value *,
243  struct expression *,
244  int *, LONGEST *, int *,
245  int, LONGEST, LONGEST);
246 
247 static void aggregate_assign_positional (struct value *, struct value *,
248  struct expression *,
249  int *, LONGEST *, int *, int,
250  LONGEST, LONGEST);
251 
252 
253 static void aggregate_assign_others (struct value *, struct value *,
254  struct expression *,
255  int *, LONGEST *, int, LONGEST, LONGEST);
256 
257 
258 static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int);
259 
260 
261 static struct value *ada_evaluate_subexp (struct type *, struct expression *,
262  int *, enum noside);
263 
264 static void ada_forward_operator_length (struct expression *, int, int *,
265  int *);
266 
267 static struct type *ada_find_any_type (const char *name);
268 
269 
270 /* The result of a symbol lookup to be stored in our symbol cache. */
271 
273 {
274  /* The name used to perform the lookup. */
275  const char *name;
276  /* The namespace used during the lookup. */
278  /* The symbol returned by the lookup, or NULL if no matching symbol
279  was found. */
280  struct symbol *sym;
281  /* The block where the symbol was found, or NULL if no matching
282  symbol was found. */
283  const struct block *block;
284  /* A pointer to the next entry with the same hash. */
285  struct cache_entry *next;
286 };
287 
288 /* The Ada symbol cache, used to store the result of Ada-mode symbol
289  lookups in the course of executing the user's commands.
290 
291  The cache is implemented using a simple, fixed-sized hash.
292  The size is fixed on the grounds that there are not likely to be
293  all that many symbols looked up during any given session, regardless
294  of the size of the symbol table. If we decide to go to a resizable
295  table, let's just use the stuff from libiberty instead. */
296 
297 #define HASH_SIZE 1009
298 
300 {
301  /* An obstack used to store the entries in our cache. */
302  struct obstack cache_space;
303 
304  /* The root of the hash table used to implement our symbol cache. */
306 };
307 
308 static void ada_free_symbol_cache (struct ada_symbol_cache *sym_cache);
309 
310 /* Maximum-sized dynamic type. */
311 static unsigned int varsize_limit;
312 
313 /* FIXME: brobecker/2003-09-17: No longer a const because it is
314  returned by a function that does not return a const char *. */
316 #ifdef VMS
317  " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
318 #else
319  " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
320 #endif
321 
322 /* The name of the symbol to use to get the name of the main subprogram. */
323 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
324  = "__gnat_ada_main_program_name";
325 
326 /* Limit on the number of warnings to raise per expression evaluation. */
327 static int warning_limit = 2;
328 
329 /* Number of warning messages issued; reset to 0 by cleanups after
330  expression evaluation. */
331 static int warnings_issued = 0;
332 
333 static const char *known_runtime_file_name_patterns[] = {
335 };
336 
339 };
340 
341 /* Space for allocating results of ada_lookup_symbol_list. */
342 static struct obstack symbol_list_obstack;
343 
344 /* Maintenance-related settings for this module. */
345 
348 
349 /* Implement the "maintenance set ada" (prefix) command. */
350 
351 static void
352 maint_set_ada_cmd (char *args, int from_tty)
353 {
354  help_list (maint_set_ada_cmdlist, "maintenance set ada ", all_commands,
355  gdb_stdout);
356 }
357 
358 /* Implement the "maintenance show ada" (prefix) command. */
359 
360 static void
361 maint_show_ada_cmd (char *args, int from_tty)
362 {
363  cmd_show_list (maint_show_ada_cmdlist, from_tty, "");
364 }
365 
366 /* The "maintenance ada set/show ignore-descriptive-type" value. */
367 
369 
370  /* Inferior-specific data. */
371 
372 /* Per-inferior data for this module. */
373 
375 {
376  /* The ada__tags__type_specific_data type, which is used when decoding
377  tagged types. With older versions of GNAT, this type was directly
378  accessible through a component ("tsd") in the object tag. But this
379  is no longer the case, so we cache it for each inferior. */
380  struct type *tsd_type;
381 
382  /* The exception_support_info data. This data is used to determine
383  how to implement support for Ada exception catchpoints in a given
384  inferior. */
386 };
387 
388 /* Our key to this module's inferior data. */
389 static const struct inferior_data *ada_inferior_data;
390 
391 /* A cleanup routine for our inferior data. */
392 static void
394 {
395  struct ada_inferior_data *data;
396 
397  data = inferior_data (inf, ada_inferior_data);
398  if (data != NULL)
399  xfree (data);
400 }
401 
402 /* Return our inferior data for the given inferior (INF).
403 
404  This function always returns a valid pointer to an allocated
405  ada_inferior_data structure. If INF's inferior data has not
406  been previously set, this functions creates a new one with all
407  fields set to zero, sets INF's inferior to it, and then returns
408  a pointer to that newly allocated ada_inferior_data. */
409 
410 static struct ada_inferior_data *
412 {
413  struct ada_inferior_data *data;
414 
415  data = inferior_data (inf, ada_inferior_data);
416  if (data == NULL)
417  {
418  data = XCNEW (struct ada_inferior_data);
419  set_inferior_data (inf, ada_inferior_data, data);
420  }
421 
422  return data;
423 }
424 
425 /* Perform all necessary cleanups regarding our module's inferior data
426  that is required after the inferior INF just exited. */
427 
428 static void
430 {
431  ada_inferior_data_cleanup (inf, NULL);
432  set_inferior_data (inf, ada_inferior_data, NULL);
433 }
434 
435 
436  /* program-space-specific data. */
437 
438 /* This module's per-program-space data. */
440 {
441  /* The Ada symbol cache. */
443 };
444 
445 /* Key to our per-program-space data. */
446 static const struct program_space_data *ada_pspace_data_handle;
447 
448 /* Return this module's data for the given program space (PSPACE).
449  If not is found, add a zero'ed one now.
450 
451  This function always returns a valid object. */
452 
453 static struct ada_pspace_data *
455 {
456  struct ada_pspace_data *data;
457 
458  data = program_space_data (pspace, ada_pspace_data_handle);
459  if (data == NULL)
460  {
461  data = XCNEW (struct ada_pspace_data);
462  set_program_space_data (pspace, ada_pspace_data_handle, data);
463  }
464 
465  return data;
466 }
467 
468 /* The cleanup callback for this module's per-program-space data. */
469 
470 static void
471 ada_pspace_data_cleanup (struct program_space *pspace, void *data)
472 {
473  struct ada_pspace_data *pspace_data = data;
474 
475  if (pspace_data->sym_cache != NULL)
476  ada_free_symbol_cache (pspace_data->sym_cache);
477  xfree (pspace_data);
478 }
479 
480  /* Utilities */
481 
482 /* If TYPE is a TYPE_CODE_TYPEDEF type, return the target type after
483  all typedef layers have been peeled. Otherwise, return TYPE.
484 
485  Normally, we really expect a typedef type to only have 1 typedef layer.
486  In other words, we really expect the target type of a typedef type to be
487  a non-typedef type. This is particularly true for Ada units, because
488  the language does not have a typedef vs not-typedef distinction.
489  In that respect, the Ada compiler has been trying to eliminate as many
490  typedef definitions in the debugging information, since they generally
491  do not bring any extra information (we still use typedef under certain
492  circumstances related mostly to the GNAT encoding).
493 
494  Unfortunately, we have seen situations where the debugging information
495  generated by the compiler leads to such multiple typedef layers. For
496  instance, consider the following example with stabs:
497 
498  .stabs "pck__float_array___XUP:Tt(0,46)=s16P_ARRAY:(0,47)=[...]"[...]
499  .stabs "pck__float_array___XUP:t(0,36)=(0,46)",128,0,6,0
500 
501  This is an error in the debugging information which causes type
502  pck__float_array___XUP to be defined twice, and the second time,
503  it is defined as a typedef of a typedef.
504 
505  This is on the fringe of legality as far as debugging information is
506  concerned, and certainly unexpected. But it is easy to handle these
507  situations correctly, so we can afford to be lenient in this case. */
508 
509 static struct type *
511 {
512  while (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
513  type = TYPE_TARGET_TYPE (type);
514  return type;
515 }
516 
517 /* Given DECODED_NAME a string holding a symbol name in its
518  decoded form (ie using the Ada dotted notation), returns
519  its unqualified name. */
520 
521 static const char *
522 ada_unqualified_name (const char *decoded_name)
523 {
524  const char *result;
525 
526  /* If the decoded name starts with '<', it means that the encoded
527  name does not follow standard naming conventions, and thus that
528  it is not your typical Ada symbol name. Trying to unqualify it
529  is therefore pointless and possibly erroneous. */
530  if (decoded_name[0] == '<')
531  return decoded_name;
532 
533  result = strrchr (decoded_name, '.');
534  if (result != NULL)
535  result++; /* Skip the dot... */
536  else
537  result = decoded_name;
538 
539  return result;
540 }
541 
542 /* Return a string starting with '<', followed by STR, and '>'.
543  The result is good until the next call. */
544 
545 static char *
546 add_angle_brackets (const char *str)
547 {
548  static char *result = NULL;
549 
550  xfree (result);
551  result = xstrprintf ("<%s>", str);
552  return result;
553 }
554 
555 static char *
557 {
559 }
560 
561 /* Print an array element index using the Ada syntax. */
562 
563 static void
564 ada_print_array_index (struct value *index_value, struct ui_file *stream,
565  const struct value_print_options *options)
566 {
567  LA_VALUE_PRINT (index_value, stream, options);
568  fprintf_filtered (stream, " => ");
569 }
570 
571 /* Assuming VECT points to an array of *SIZE objects of size
572  ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
573  updating *SIZE as necessary and returning the (new) array. */
574 
575 void *
576 grow_vect (void *vect, size_t *size, size_t min_size, int element_size)
577 {
578  if (*size < min_size)
579  {
580  *size *= 2;
581  if (*size < min_size)
582  *size = min_size;
583  vect = xrealloc (vect, *size * element_size);
584  }
585  return vect;
586 }
587 
588 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
589  suffix of FIELD_NAME beginning "___". */
590 
591 static int
592 field_name_match (const char *field_name, const char *target)
593 {
594  int len = strlen (target);
595 
596  return
597  (strncmp (field_name, target, len) == 0
598  && (field_name[len] == '\0'
599  || (startswith (field_name + len, "___")
600  && strcmp (field_name + strlen (field_name) - 6,
601  "___XVN") != 0)));
602 }
603 
604 
605 /* Assuming TYPE is a TYPE_CODE_STRUCT or a TYPE_CODE_TYPDEF to
606  a TYPE_CODE_STRUCT, find the field whose name matches FIELD_NAME,
607  and return its index. This function also handles fields whose name
608  have ___ suffixes because the compiler sometimes alters their name
609  by adding such a suffix to represent fields with certain constraints.
610  If the field could not be found, return a negative number if
611  MAYBE_MISSING is set. Otherwise raise an error. */
612 
613 int
614 ada_get_field_index (const struct type *type, const char *field_name,
615  int maybe_missing)
616 {
617  int fieldno;
618  struct type *struct_type = check_typedef ((struct type *) type);
619 
620  for (fieldno = 0; fieldno < TYPE_NFIELDS (struct_type); fieldno++)
621  if (field_name_match (TYPE_FIELD_NAME (struct_type, fieldno), field_name))
622  return fieldno;
623 
624  if (!maybe_missing)
625  error (_("Unable to find field %s in struct %s. Aborting"),
626  field_name, TYPE_NAME (struct_type));
627 
628  return -1;
629 }
630 
631 /* The length of the prefix of NAME prior to any "___" suffix. */
632 
633 int
635 {
636  if (name == NULL)
637  return 0;
638  else
639  {
640  const char *p = strstr (name, "___");
641 
642  if (p == NULL)
643  return strlen (name);
644  else
645  return p - name;
646  }
647 }
648 
649 /* Return non-zero if SUFFIX is a suffix of STR.
650  Return zero if STR is null. */
651 
652 static int
653 is_suffix (const char *str, const char *suffix)
654 {
655  int len1, len2;
656 
657  if (str == NULL)
658  return 0;
659  len1 = strlen (str);
660  len2 = strlen (suffix);
661  return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
662 }
663 
664 /* The contents of value VAL, treated as a value of type TYPE. The
665  result is an lval in memory if VAL is. */
666 
667 static struct value *
668 coerce_unspec_val_to_type (struct value *val, struct type *type)
669 {
670  type = ada_check_typedef (type);
671  if (value_type (val) == type)
672  return val;
673  else
674  {
675  struct value *result;
676 
677  /* Make sure that the object size is not unreasonable before
678  trying to allocate some memory for it. */
680 
681  if (value_lazy (val)
682  || TYPE_LENGTH (type) > TYPE_LENGTH (value_type (val)))
683  result = allocate_value_lazy (type);
684  else
685  {
686  result = allocate_value (type);
687  value_contents_copy_raw (result, 0, val, 0, TYPE_LENGTH (type));
688  }
689  set_value_component_location (result, val);
690  set_value_bitsize (result, value_bitsize (val));
691  set_value_bitpos (result, value_bitpos (val));
692  set_value_address (result, value_address (val));
693  return result;
694  }
695 }
696 
697 static const gdb_byte *
698 cond_offset_host (const gdb_byte *valaddr, long offset)
699 {
700  if (valaddr == NULL)
701  return NULL;
702  else
703  return valaddr + offset;
704 }
705 
706 static CORE_ADDR
708 {
709  if (address == 0)
710  return 0;
711  else
712  return address + offset;
713 }
714 
715 /* Issue a warning (as for the definition of warning in utils.c, but
716  with exactly one argument rather than ...), unless the limit on the
717  number of warnings has passed during the evaluation of the current
718  expression. */
719 
720 /* FIXME: cagney/2004-10-10: This function is mimicking the behavior
721  provided by "complaint". */
722 static void lim_warning (const char *format, ...) ATTRIBUTE_PRINTF (1, 2);
723 
724 static void
725 lim_warning (const char *format, ...)
726 {
727  va_list args;
728 
729  va_start (args, format);
730  warnings_issued += 1;
731  if (warnings_issued <= warning_limit)
732  vwarning (format, args);
733 
734  va_end (args);
735 }
736 
737 /* Issue an error if the size of an object of type T is unreasonable,
738  i.e. if it would be a bad idea to allocate a value of this type in
739  GDB. */
740 
741 void
743 {
744  if (TYPE_LENGTH (type) > varsize_limit)
745  error (_("object size is larger than varsize-limit"));
746 }
747 
748 /* Maximum value of a SIZE-byte signed integer type. */
749 static LONGEST
751 {
752  LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
753 
754  return top_bit | (top_bit - 1);
755 }
756 
757 /* Minimum value of a SIZE-byte signed integer type. */
758 static LONGEST
760 {
761  return -max_of_size (size) - 1;
762 }
763 
764 /* Maximum value of a SIZE-byte unsigned integer type. */
765 static ULONGEST
767 {
768  ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
769 
770  return top_bit | (top_bit - 1);
771 }
772 
773 /* Maximum value of integral type T, as a signed quantity. */
774 static LONGEST
775 max_of_type (struct type *t)
776 {
777  if (TYPE_UNSIGNED (t))
778  return (LONGEST) umax_of_size (TYPE_LENGTH (t));
779  else
780  return max_of_size (TYPE_LENGTH (t));
781 }
782 
783 /* Minimum value of integral type T, as a signed quantity. */
784 static LONGEST
785 min_of_type (struct type *t)
786 {
787  if (TYPE_UNSIGNED (t))
788  return 0;
789  else
790  return min_of_size (TYPE_LENGTH (t));
791 }
792 
793 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
794 LONGEST
796 {
797  type = resolve_dynamic_type (type, NULL, 0);
798  switch (TYPE_CODE (type))
799  {
800  case TYPE_CODE_RANGE:
801  return TYPE_HIGH_BOUND (type);
802  case TYPE_CODE_ENUM:
803  return TYPE_FIELD_ENUMVAL (type, TYPE_NFIELDS (type) - 1);
804  case TYPE_CODE_BOOL:
805  return 1;
806  case TYPE_CODE_CHAR:
807  case TYPE_CODE_INT:
808  return max_of_type (type);
809  default:
810  error (_("Unexpected type in ada_discrete_type_high_bound."));
811  }
812 }
813 
814 /* The smallest value in the domain of TYPE, a discrete type, as an integer. */
815 LONGEST
817 {
818  type = resolve_dynamic_type (type, NULL, 0);
819  switch (TYPE_CODE (type))
820  {
821  case TYPE_CODE_RANGE:
822  return TYPE_LOW_BOUND (type);
823  case TYPE_CODE_ENUM:
824  return TYPE_FIELD_ENUMVAL (type, 0);
825  case TYPE_CODE_BOOL:
826  return 0;
827  case TYPE_CODE_CHAR:
828  case TYPE_CODE_INT:
829  return min_of_type (type);
830  default:
831  error (_("Unexpected type in ada_discrete_type_low_bound."));
832  }
833 }
834 
835 /* The identity on non-range types. For range types, the underlying
836  non-range scalar type. */
837 
838 static struct type *
840 {
841  while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
842  {
843  if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
844  return type;
845  type = TYPE_TARGET_TYPE (type);
846  }
847  return type;
848 }
849 
850 /* Return a decoded version of the given VALUE. This means returning
851  a value whose type is obtained by applying all the GNAT-specific
852  encondings, making the resulting type a static but standard description
853  of the initial type. */
854 
855 struct value *
857 {
858  struct type *type = ada_check_typedef (value_type (value));
859 
862  && TYPE_CODE (type) != TYPE_CODE_PTR))
863  {
864  if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF) /* array access type. */
865  value = ada_coerce_to_simple_array_ptr (value);
866  else
867  value = ada_coerce_to_simple_array (value);
868  }
869  else
870  value = ada_to_fixed_value (value);
871 
872  return value;
873 }
874 
875 /* Same as ada_get_decoded_value, but with the given TYPE.
876  Because there is no associated actual value for this type,
877  the resulting type might be a best-effort approximation in
878  the case of dynamic types. */
879 
880 struct type *
882 {
883  type = to_static_fixed_type (type);
885  type = ada_coerce_to_simple_array_type (type);
886  return type;
887 }
888 
889 
890 
891  /* Language Selection */
892 
893 /* If the main program is in Ada, return language_ada, otherwise return LANG
894  (the main program is in Ada iif the adainit symbol is found). */
895 
896 enum language
898 {
899  if (lookup_minimal_symbol ("adainit", (const char *) NULL,
900  (struct objfile *) NULL).minsym != NULL)
901  return language_ada;
902 
903  return lang;
904 }
905 
906 /* If the main procedure is written in Ada, then return its name.
907  The result is good until the next call. Return NULL if the main
908  procedure doesn't appear to be in Ada. */
909 
910 char *
912 {
913  struct bound_minimal_symbol msym;
914  static char *main_program_name = NULL;
915 
916  /* For Ada, the name of the main procedure is stored in a specific
917  string constant, generated by the binder. Look for that symbol,
918  extract its address, and then read that string. If we didn't find
919  that string, then most probably the main procedure is not written
920  in Ada. */
922 
923  if (msym.minsym != NULL)
924  {
925  CORE_ADDR main_program_name_addr;
926  int err_code;
927 
928  main_program_name_addr = BMSYMBOL_VALUE_ADDRESS (msym);
929  if (main_program_name_addr == 0)
930  error (_("Invalid address for Ada main program name."));
931 
932  xfree (main_program_name);
933  target_read_string (main_program_name_addr, &main_program_name,
934  1024, &err_code);
935 
936  if (err_code != 0)
937  return NULL;
938  return main_program_name;
939  }
940 
941  /* The main procedure doesn't seem to be in Ada. */
942  return NULL;
943 }
944 
945  /* Symbols */
946 
947 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
948  of NULLs. */
949 
950 const struct ada_opname_map ada_opname_table[] = {
951  {"Oadd", "\"+\"", BINOP_ADD},
952  {"Osubtract", "\"-\"", BINOP_SUB},
953  {"Omultiply", "\"*\"", BINOP_MUL},
954  {"Odivide", "\"/\"", BINOP_DIV},
955  {"Omod", "\"mod\"", BINOP_MOD},
956  {"Orem", "\"rem\"", BINOP_REM},
957  {"Oexpon", "\"**\"", BINOP_EXP},
958  {"Olt", "\"<\"", BINOP_LESS},
959  {"Ole", "\"<=\"", BINOP_LEQ},
960  {"Ogt", "\">\"", BINOP_GTR},
961  {"Oge", "\">=\"", BINOP_GEQ},
962  {"Oeq", "\"=\"", BINOP_EQUAL},
963  {"One", "\"/=\"", BINOP_NOTEQUAL},
964  {"Oand", "\"and\"", BINOP_BITWISE_AND},
965  {"Oor", "\"or\"", BINOP_BITWISE_IOR},
966  {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
967  {"Oconcat", "\"&\"", BINOP_CONCAT},
968  {"Oabs", "\"abs\"", UNOP_ABS},
969  {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
970  {"Oadd", "\"+\"", UNOP_PLUS},
971  {"Osubtract", "\"-\"", UNOP_NEG},
972  {NULL, NULL}
973 };
974 
975 /* The "encoded" form of DECODED, according to GNAT conventions.
976  The result is valid until the next call to ada_encode. */
977 
978 char *
979 ada_encode (const char *decoded)
980 {
981  static char *encoding_buffer = NULL;
982  static size_t encoding_buffer_size = 0;
983  const char *p;
984  int k;
985 
986  if (decoded == NULL)
987  return NULL;
988 
989  GROW_VECT (encoding_buffer, encoding_buffer_size,
990  2 * strlen (decoded) + 10);
991 
992  k = 0;
993  for (p = decoded; *p != '\0'; p += 1)
994  {
995  if (*p == '.')
996  {
997  encoding_buffer[k] = encoding_buffer[k + 1] = '_';
998  k += 2;
999  }
1000  else if (*p == '"')
1001  {
1002  const struct ada_opname_map *mapping;
1003 
1004  for (mapping = ada_opname_table;
1005  mapping->encoded != NULL
1006  && !startswith (p, mapping->decoded); mapping += 1)
1007  ;
1008  if (mapping->encoded == NULL)
1009  error (_("invalid Ada operator name: %s"), p);
1010  strcpy (encoding_buffer + k, mapping->encoded);
1011  k += strlen (mapping->encoded);
1012  break;
1013  }
1014  else
1015  {
1016  encoding_buffer[k] = *p;
1017  k += 1;
1018  }
1019  }
1020 
1021  encoding_buffer[k] = '\0';
1022  return encoding_buffer;
1023 }
1024 
1025 /* Return NAME folded to lower case, or, if surrounded by single
1026  quotes, unfolded, but with the quotes stripped away. Result good
1027  to next call. */
1028 
1029 char *
1030 ada_fold_name (const char *name)
1031 {
1032  static char *fold_buffer = NULL;
1033  static size_t fold_buffer_size = 0;
1034 
1035  int len = strlen (name);
1036  GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
1037 
1038  if (name[0] == '\'')
1039  {
1040  strncpy (fold_buffer, name + 1, len - 2);
1041  fold_buffer[len - 2] = '\000';
1042  }
1043  else
1044  {
1045  int i;
1046 
1047  for (i = 0; i <= len; i += 1)
1048  fold_buffer[i] = tolower (name[i]);
1049  }
1050 
1051  return fold_buffer;
1052 }
1053 
1054 /* Return nonzero if C is either a digit or a lowercase alphabet character. */
1055 
1056 static int
1057 is_lower_alphanum (const char c)
1058 {
1059  return (isdigit (c) || (isalpha (c) && islower (c)));
1060 }
1061 
1062 /* ENCODED is the linkage name of a symbol and LEN contains its length.
1063  This function saves in LEN the length of that same symbol name but
1064  without either of these suffixes:
1065  . .{DIGIT}+
1066  . ${DIGIT}+
1067  . ___{DIGIT}+
1068  . __{DIGIT}+.
1069 
1070  These are suffixes introduced by the compiler for entities such as
1071  nested subprogram for instance, in order to avoid name clashes.
1072  They do not serve any purpose for the debugger. */
1073 
1074 static void
1076 {
1077  if (*len > 1 && isdigit (encoded[*len - 1]))
1078  {
1079  int i = *len - 2;
1080 
1081  while (i > 0 && isdigit (encoded[i]))
1082  i--;
1083  if (i >= 0 && encoded[i] == '.')
1084  *len = i;
1085  else if (i >= 0 && encoded[i] == '$')
1086  *len = i;
1087  else if (i >= 2 && startswith (encoded + i - 2, "___"))
1088  *len = i - 2;
1089  else if (i >= 1 && startswith (encoded + i - 1, "__"))
1090  *len = i - 1;
1091  }
1092 }
1093 
1094 /* Remove the suffix introduced by the compiler for protected object
1095  subprograms. */
1096 
1097 static void
1099 {
1100  /* Remove trailing N. */
1101 
1102  /* Protected entry subprograms are broken into two
1103  separate subprograms: The first one is unprotected, and has
1104  a 'N' suffix; the second is the protected version, and has
1105  the 'P' suffix. The second calls the first one after handling
1106  the protection. Since the P subprograms are internally generated,
1107  we leave these names undecoded, giving the user a clue that this
1108  entity is internal. */
1109 
1110  if (*len > 1
1111  && encoded[*len - 1] == 'N'
1112  && (isdigit (encoded[*len - 2]) || islower (encoded[*len - 2])))
1113  *len = *len - 1;
1114 }
1115 
1116 /* Remove trailing X[bn]* suffixes (indicating names in package bodies). */
1117 
1118 static void
1119 ada_remove_Xbn_suffix (const char *encoded, int *len)
1120 {
1121  int i = *len - 1;
1122 
1123  while (i > 0 && (encoded[i] == 'b' || encoded[i] == 'n'))
1124  i--;
1125 
1126  if (encoded[i] != 'X')
1127  return;
1128 
1129  if (i == 0)
1130  return;
1131 
1132  if (isalnum (encoded[i-1]))
1133  *len = i;
1134 }
1135 
1136 /* If ENCODED follows the GNAT entity encoding conventions, then return
1137  the decoded form of ENCODED. Otherwise, return "<%s>" where "%s" is
1138  replaced by ENCODED.
1139 
1140  The resulting string is valid until the next call of ada_decode.
1141  If the string is unchanged by decoding, the original string pointer
1142  is returned. */
1143 
1144 const char *
1145 ada_decode (const char *encoded)
1146 {
1147  int i, j;
1148  int len0;
1149  const char *p;
1150  char *decoded;
1151  int at_start_name;
1152  static char *decoding_buffer = NULL;
1153  static size_t decoding_buffer_size = 0;
1154 
1155  /* The name of the Ada main procedure starts with "_ada_".
1156  This prefix is not part of the decoded name, so skip this part
1157  if we see this prefix. */
1158  if (startswith (encoded, "_ada_"))
1159  encoded += 5;
1160 
1161  /* If the name starts with '_', then it is not a properly encoded
1162  name, so do not attempt to decode it. Similarly, if the name
1163  starts with '<', the name should not be decoded. */
1164  if (encoded[0] == '_' || encoded[0] == '<')
1165  goto Suppress;
1166 
1167  len0 = strlen (encoded);
1168 
1169  ada_remove_trailing_digits (encoded, &len0);
1170  ada_remove_po_subprogram_suffix (encoded, &len0);
1171 
1172  /* Remove the ___X.* suffix if present. Do not forget to verify that
1173  the suffix is located before the current "end" of ENCODED. We want
1174  to avoid re-matching parts of ENCODED that have previously been
1175  marked as discarded (by decrementing LEN0). */
1176  p = strstr (encoded, "___");
1177  if (p != NULL && p - encoded < len0 - 3)
1178  {
1179  if (p[3] == 'X')
1180  len0 = p - encoded;
1181  else
1182  goto Suppress;
1183  }
1184 
1185  /* Remove any trailing TKB suffix. It tells us that this symbol
1186  is for the body of a task, but that information does not actually
1187  appear in the decoded name. */
1188 
1189  if (len0 > 3 && startswith (encoded + len0 - 3, "TKB"))
1190  len0 -= 3;
1191 
1192  /* Remove any trailing TB suffix. The TB suffix is slightly different
1193  from the TKB suffix because it is used for non-anonymous task
1194  bodies. */
1195 
1196  if (len0 > 2 && startswith (encoded + len0 - 2, "TB"))
1197  len0 -= 2;
1198 
1199  /* Remove trailing "B" suffixes. */
1200  /* FIXME: brobecker/2006-04-19: Not sure what this are used for... */
1201 
1202  if (len0 > 1 && startswith (encoded + len0 - 1, "B"))
1203  len0 -= 1;
1204 
1205  /* Make decoded big enough for possible expansion by operator name. */
1206 
1207  GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
1208  decoded = decoding_buffer;
1209 
1210  /* Remove trailing __{digit}+ or trailing ${digit}+. */
1211 
1212  if (len0 > 1 && isdigit (encoded[len0 - 1]))
1213  {
1214  i = len0 - 2;
1215  while ((i >= 0 && isdigit (encoded[i]))
1216  || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
1217  i -= 1;
1218  if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
1219  len0 = i - 1;
1220  else if (encoded[i] == '$')
1221  len0 = i;
1222  }
1223 
1224  /* The first few characters that are not alphabetic are not part
1225  of any encoding we use, so we can copy them over verbatim. */
1226 
1227  for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
1228  decoded[j] = encoded[i];
1229 
1230  at_start_name = 1;
1231  while (i < len0)
1232  {
1233  /* Is this a symbol function? */
1234  if (at_start_name && encoded[i] == 'O')
1235  {
1236  int k;
1237 
1238  for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
1239  {
1240  int op_len = strlen (ada_opname_table[k].encoded);
1241  if ((strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
1242  op_len - 1) == 0)
1243  && !isalnum (encoded[i + op_len]))
1244  {
1245  strcpy (decoded + j, ada_opname_table[k].decoded);
1246  at_start_name = 0;
1247  i += op_len;
1248  j += strlen (ada_opname_table[k].decoded);
1249  break;
1250  }
1251  }
1252  if (ada_opname_table[k].encoded != NULL)
1253  continue;
1254  }
1255  at_start_name = 0;
1256 
1257  /* Replace "TK__" with "__", which will eventually be translated
1258  into "." (just below). */
1259 
1260  if (i < len0 - 4 && startswith (encoded + i, "TK__"))
1261  i += 2;
1262 
1263  /* Replace "__B_{DIGITS}+__" sequences by "__", which will eventually
1264  be translated into "." (just below). These are internal names
1265  generated for anonymous blocks inside which our symbol is nested. */
1266 
1267  if (len0 - i > 5 && encoded [i] == '_' && encoded [i+1] == '_'
1268  && encoded [i+2] == 'B' && encoded [i+3] == '_'
1269  && isdigit (encoded [i+4]))
1270  {
1271  int k = i + 5;
1272 
1273  while (k < len0 && isdigit (encoded[k]))
1274  k++; /* Skip any extra digit. */
1275 
1276  /* Double-check that the "__B_{DIGITS}+" sequence we found
1277  is indeed followed by "__". */
1278  if (len0 - k > 2 && encoded [k] == '_' && encoded [k+1] == '_')
1279  i = k;
1280  }
1281 
1282  /* Remove _E{DIGITS}+[sb] */
1283 
1284  /* Just as for protected object subprograms, there are 2 categories
1285  of subprograms created by the compiler for each entry. The first
1286  one implements the actual entry code, and has a suffix following
1287  the convention above; the second one implements the barrier and
1288  uses the same convention as above, except that the 'E' is replaced
1289  by a 'B'.
1290 
1291  Just as above, we do not decode the name of barrier functions
1292  to give the user a clue that the code he is debugging has been
1293  internally generated. */
1294 
1295  if (len0 - i > 3 && encoded [i] == '_' && encoded[i+1] == 'E'
1296  && isdigit (encoded[i+2]))
1297  {
1298  int k = i + 3;
1299 
1300  while (k < len0 && isdigit (encoded[k]))
1301  k++;
1302 
1303  if (k < len0
1304  && (encoded[k] == 'b' || encoded[k] == 's'))
1305  {
1306  k++;
1307  /* Just as an extra precaution, make sure that if this
1308  suffix is followed by anything else, it is a '_'.
1309  Otherwise, we matched this sequence by accident. */
1310  if (k == len0
1311  || (k < len0 && encoded[k] == '_'))
1312  i = k;
1313  }
1314  }
1315 
1316  /* Remove trailing "N" in [a-z0-9]+N__. The N is added by
1317  the GNAT front-end in protected object subprograms. */
1318 
1319  if (i < len0 + 3
1320  && encoded[i] == 'N' && encoded[i+1] == '_' && encoded[i+2] == '_')
1321  {
1322  /* Backtrack a bit up until we reach either the begining of
1323  the encoded name, or "__". Make sure that we only find
1324  digits or lowercase characters. */
1325  const char *ptr = encoded + i - 1;
1326 
1327  while (ptr >= encoded && is_lower_alphanum (ptr[0]))
1328  ptr--;
1329  if (ptr < encoded
1330  || (ptr > encoded && ptr[0] == '_' && ptr[-1] == '_'))
1331  i++;
1332  }
1333 
1334  if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1335  {
1336  /* This is a X[bn]* sequence not separated from the previous
1337  part of the name with a non-alpha-numeric character (in other
1338  words, immediately following an alpha-numeric character), then
1339  verify that it is placed at the end of the encoded name. If
1340  not, then the encoding is not valid and we should abort the
1341  decoding. Otherwise, just skip it, it is used in body-nested
1342  package names. */
1343  do
1344  i += 1;
1345  while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1346  if (i < len0)
1347  goto Suppress;
1348  }
1349  else if (i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1350  {
1351  /* Replace '__' by '.'. */
1352  decoded[j] = '.';
1353  at_start_name = 1;
1354  i += 2;
1355  j += 1;
1356  }
1357  else
1358  {
1359  /* It's a character part of the decoded name, so just copy it
1360  over. */
1361  decoded[j] = encoded[i];
1362  i += 1;
1363  j += 1;
1364  }
1365  }
1366  decoded[j] = '\000';
1367 
1368  /* Decoded names should never contain any uppercase character.
1369  Double-check this, and abort the decoding if we find one. */
1370 
1371  for (i = 0; decoded[i] != '\0'; i += 1)
1372  if (isupper (decoded[i]) || decoded[i] == ' ')
1373  goto Suppress;
1374 
1375  if (strcmp (decoded, encoded) == 0)
1376  return encoded;
1377  else
1378  return decoded;
1379 
1380 Suppress:
1381  GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1382  decoded = decoding_buffer;
1383  if (encoded[0] == '<')
1384  strcpy (decoded, encoded);
1385  else
1386  xsnprintf (decoded, decoding_buffer_size, "<%s>", encoded);
1387  return decoded;
1388 
1389 }
1390 
1391 /* Table for keeping permanent unique copies of decoded names. Once
1392  allocated, names in this table are never released. While this is a
1393  storage leak, it should not be significant unless there are massive
1394  changes in the set of decoded names in successive versions of a
1395  symbol table loaded during a single session. */
1396 static struct htab *decoded_names_store;
1397 
1398 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1399  in the language-specific part of GSYMBOL, if it has not been
1400  previously computed. Tries to save the decoded name in the same
1401  obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1402  in any case, the decoded symbol has a lifetime at least that of
1403  GSYMBOL).
1404  The GSYMBOL parameter is "mutable" in the C++ sense: logically
1405  const, but nevertheless modified to a semantically equivalent form
1406  when a decoded name is cached in it. */
1407 
1408 const char *
1410 {
1411  struct general_symbol_info *gsymbol = (struct general_symbol_info *) arg;
1412  const char **resultp =
1413  &gsymbol->language_specific.mangled_lang.demangled_name;
1414 
1415  if (!gsymbol->ada_mangled)
1416  {
1417  const char *decoded = ada_decode (gsymbol->name);
1418  struct obstack *obstack = gsymbol->language_specific.obstack;
1419 
1420  gsymbol->ada_mangled = 1;
1421 
1422  if (obstack != NULL)
1423  *resultp = obstack_copy0 (obstack, decoded, strlen (decoded));
1424  else
1425  {
1426  /* Sometimes, we can't find a corresponding objfile, in
1427  which case, we put the result on the heap. Since we only
1428  decode when needed, we hope this usually does not cause a
1429  significant memory leak (FIXME). */
1430 
1431  char **slot = (char **) htab_find_slot (decoded_names_store,
1432  decoded, INSERT);
1433 
1434  if (*slot == NULL)
1435  *slot = xstrdup (decoded);
1436  *resultp = *slot;
1437  }
1438  }
1439 
1440  return *resultp;
1441 }
1442 
1443 static char *
1444 ada_la_decode (const char *encoded, int options)
1445 {
1446  return xstrdup (ada_decode (encoded));
1447 }
1448 
1449 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1450  suffixes that encode debugging information or leading _ada_ on
1451  SYM_NAME (see is_name_suffix commentary for the debugging
1452  information that is ignored). If WILD, then NAME need only match a
1453  suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1454  either argument is NULL. */
1455 
1456 static int
1457 match_name (const char *sym_name, const char *name, int wild)
1458 {
1459  if (sym_name == NULL || name == NULL)
1460  return 0;
1461  else if (wild)
1462  return wild_match (sym_name, name) == 0;
1463  else
1464  {
1465  int len_name = strlen (name);
1466 
1467  return (strncmp (sym_name, name, len_name) == 0
1468  && is_name_suffix (sym_name + len_name))
1469  || (startswith (sym_name, "_ada_")
1470  && strncmp (sym_name + 5, name, len_name) == 0
1471  && is_name_suffix (sym_name + len_name + 5));
1472  }
1473 }
1474 
1475 
1476  /* Arrays */
1477 
1478 /* Assuming that INDEX_DESC_TYPE is an ___XA structure, a structure
1479  generated by the GNAT compiler to describe the index type used
1480  for each dimension of an array, check whether it follows the latest
1481  known encoding. If not, fix it up to conform to the latest encoding.
1482  Otherwise, do nothing. This function also does nothing if
1483  INDEX_DESC_TYPE is NULL.
1484 
1485  The GNAT encoding used to describle the array index type evolved a bit.
1486  Initially, the information would be provided through the name of each
1487  field of the structure type only, while the type of these fields was
1488  described as unspecified and irrelevant. The debugger was then expected
1489  to perform a global type lookup using the name of that field in order
1490  to get access to the full index type description. Because these global
1491  lookups can be very expensive, the encoding was later enhanced to make
1492  the global lookup unnecessary by defining the field type as being
1493  the full index type description.
1494 
1495  The purpose of this routine is to allow us to support older versions
1496  of the compiler by detecting the use of the older encoding, and by
1497  fixing up the INDEX_DESC_TYPE to follow the new one (at this point,
1498  we essentially replace each field's meaningless type by the associated
1499  index subtype). */
1500 
1501 void
1502 ada_fixup_array_indexes_type (struct type *index_desc_type)
1503 {
1504  int i;
1505 
1506  if (index_desc_type == NULL)
1507  return;
1508  gdb_assert (TYPE_NFIELDS (index_desc_type) > 0);
1509 
1510  /* Check if INDEX_DESC_TYPE follows the older encoding (it is sufficient
1511  to check one field only, no need to check them all). If not, return
1512  now.
1513 
1514  If our INDEX_DESC_TYPE was generated using the older encoding,
1515  the field type should be a meaningless integer type whose name
1516  is not equal to the field name. */
1517  if (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)) != NULL
1518  && strcmp (TYPE_NAME (TYPE_FIELD_TYPE (index_desc_type, 0)),
1519  TYPE_FIELD_NAME (index_desc_type, 0)) == 0)
1520  return;
1521 
1522  /* Fixup each field of INDEX_DESC_TYPE. */
1523  for (i = 0; i < TYPE_NFIELDS (index_desc_type); i++)
1524  {
1525  const char *name = TYPE_FIELD_NAME (index_desc_type, i);
1526  struct type *raw_type = ada_check_typedef (ada_find_any_type (name));
1527 
1528  if (raw_type)
1529  TYPE_FIELD_TYPE (index_desc_type, i) = raw_type;
1530  }
1531 }
1532 
1533 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1534 
1535 static char *bound_name[] = {
1536  "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1537  "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1538 };
1539 
1540 /* Maximum number of array dimensions we are prepared to handle. */
1541 
1542 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1543 
1544 
1545 /* The desc_* routines return primitive portions of array descriptors
1546  (fat pointers). */
1547 
1548 /* The descriptor or array type, if any, indicated by TYPE; removes
1549  level of indirection, if needed. */
1550 
1551 static struct type *
1553 {
1554  if (type == NULL)
1555  return NULL;
1556  type = ada_check_typedef (type);
1557  if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
1558  type = ada_typedef_target_type (type);
1559 
1560  if (type != NULL
1561  && (TYPE_CODE (type) == TYPE_CODE_PTR
1562  || TYPE_CODE (type) == TYPE_CODE_REF))
1563  return ada_check_typedef (TYPE_TARGET_TYPE (type));
1564  else
1565  return type;
1566 }
1567 
1568 /* True iff TYPE indicates a "thin" array pointer type. */
1569 
1570 static int
1572 {
1573  return
1574  is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1575  || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1576 }
1577 
1578 /* The descriptor type for thin pointer type TYPE. */
1579 
1580 static struct type *
1582 {
1583  struct type *base_type = desc_base_type (type);
1584 
1585  if (base_type == NULL)
1586  return NULL;
1587  if (is_suffix (ada_type_name (base_type), "___XVE"))
1588  return base_type;
1589  else
1590  {
1591  struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
1592 
1593  if (alt_type == NULL)
1594  return base_type;
1595  else
1596  return alt_type;
1597  }
1598 }
1599 
1600 /* A pointer to the array data for thin-pointer value VAL. */
1601 
1602 static struct value *
1603 thin_data_pntr (struct value *val)
1604 {
1605  struct type *type = ada_check_typedef (value_type (val));
1606  struct type *data_type = desc_data_target_type (thin_descriptor_type (type));
1607 
1608  data_type = lookup_pointer_type (data_type);
1609 
1610  if (TYPE_CODE (type) == TYPE_CODE_PTR)
1611  return value_cast (data_type, value_copy (val));
1612  else
1613  return value_from_longest (data_type, value_address (val));
1614 }
1615 
1616 /* True iff TYPE indicates a "thick" array pointer type. */
1617 
1618 static int
1620 {
1621  type = desc_base_type (type);
1622  return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
1623  && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
1624 }
1625 
1626 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1627  pointer to one, the type of its bounds data; otherwise, NULL. */
1628 
1629 static struct type *
1631 {
1632  struct type *r;
1633 
1634  type = desc_base_type (type);
1635 
1636  if (type == NULL)
1637  return NULL;
1638  else if (is_thin_pntr (type))
1639  {
1640  type = thin_descriptor_type (type);
1641  if (type == NULL)
1642  return NULL;
1643  r = lookup_struct_elt_type (type, "BOUNDS", 1);
1644  if (r != NULL)
1645  return ada_check_typedef (r);
1646  }
1647  else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1648  {
1649  r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1650  if (r != NULL)
1652  }
1653  return NULL;
1654 }
1655 
1656 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1657  one, a pointer to its bounds data. Otherwise NULL. */
1658 
1659 static struct value *
1660 desc_bounds (struct value *arr)
1661 {
1662  struct type *type = ada_check_typedef (value_type (arr));
1663 
1664  if (is_thin_pntr (type))
1665  {
1666  struct type *bounds_type =
1668  LONGEST addr;
1669 
1670  if (bounds_type == NULL)
1671  error (_("Bad GNAT array descriptor"));
1672 
1673  /* NOTE: The following calculation is not really kosher, but
1674  since desc_type is an XVE-encoded type (and shouldn't be),
1675  the correct calculation is a real pain. FIXME (and fix GCC). */
1676  if (TYPE_CODE (type) == TYPE_CODE_PTR)
1677  addr = value_as_long (arr);
1678  else
1679  addr = value_address (arr);
1680 
1681  return
1682  value_from_longest (lookup_pointer_type (bounds_type),
1683  addr - TYPE_LENGTH (bounds_type));
1684  }
1685 
1686  else if (is_thick_pntr (type))
1687  {
1688  struct value *p_bounds = value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
1689  _("Bad GNAT array descriptor"));
1690  struct type *p_bounds_type = value_type (p_bounds);
1691 
1692  if (p_bounds_type
1693  && TYPE_CODE (p_bounds_type) == TYPE_CODE_PTR)
1694  {
1695  struct type *target_type = TYPE_TARGET_TYPE (p_bounds_type);
1696 
1697  if (TYPE_STUB (target_type))
1698  p_bounds = value_cast (lookup_pointer_type
1699  (ada_check_typedef (target_type)),
1700  p_bounds);
1701  }
1702  else
1703  error (_("Bad GNAT array descriptor"));
1704 
1705  return p_bounds;
1706  }
1707  else
1708  return NULL;
1709 }
1710 
1711 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1712  position of the field containing the address of the bounds data. */
1713 
1714 static int
1716 {
1717  return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1718 }
1719 
1720 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1721  size of the field containing the address of the bounds data. */
1722 
1723 static int
1725 {
1726  type = desc_base_type (type);
1727 
1728  if (TYPE_FIELD_BITSIZE (type, 1) > 0)
1729  return TYPE_FIELD_BITSIZE (type, 1);
1730  else
1731  return 8 * TYPE_LENGTH (ada_check_typedef (TYPE_FIELD_TYPE (type, 1)));
1732 }
1733 
1734 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1735  pointer to one, the type of its array data (a array-with-no-bounds type);
1736  otherwise, NULL. Use ada_type_of_array to get an array type with bounds
1737  data. */
1738 
1739 static struct type *
1741 {
1742  type = desc_base_type (type);
1743 
1744  /* NOTE: The following is bogus; see comment in desc_bounds. */
1745  if (is_thin_pntr (type))
1747  else if (is_thick_pntr (type))
1748  {
1749  struct type *data_type = lookup_struct_elt_type (type, "P_ARRAY", 1);
1750 
1751  if (data_type
1752  && TYPE_CODE (ada_check_typedef (data_type)) == TYPE_CODE_PTR)
1753  return ada_check_typedef (TYPE_TARGET_TYPE (data_type));
1754  }
1755 
1756  return NULL;
1757 }
1758 
1759 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1760  its array data. */
1761 
1762 static struct value *
1763 desc_data (struct value *arr)
1764 {
1765  struct type *type = value_type (arr);
1766 
1767  if (is_thin_pntr (type))
1768  return thin_data_pntr (arr);
1769  else if (is_thick_pntr (type))
1770  return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
1771  _("Bad GNAT array descriptor"));
1772  else
1773  return NULL;
1774 }
1775 
1776 
1777 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1778  position of the field containing the address of the data. */
1779 
1780 static int
1782 {
1783  return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1784 }
1785 
1786 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1787  size of the field containing the address of the data. */
1788 
1789 static int
1791 {
1792  type = desc_base_type (type);
1793 
1794  if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1795  return TYPE_FIELD_BITSIZE (type, 0);
1796  else
1797  return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1798 }
1799 
1800 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1801  the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1802  bound, if WHICH is 1. The first bound is I=1. */
1803 
1804 static struct value *
1805 desc_one_bound (struct value *bounds, int i, int which)
1806 {
1807  return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
1808  _("Bad GNAT array descriptor bounds"));
1809 }
1810 
1811 /* If BOUNDS is an array-bounds structure type, return the bit position
1812  of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1813  bound, if WHICH is 1. The first bound is I=1. */
1814 
1815 static int
1816 desc_bound_bitpos (struct type *type, int i, int which)
1817 {
1818  return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
1819 }
1820 
1821 /* If BOUNDS is an array-bounds structure type, return the bit field size
1822  of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1823  bound, if WHICH is 1. The first bound is I=1. */
1824 
1825 static int
1826 desc_bound_bitsize (struct type *type, int i, int which)
1827 {
1828  type = desc_base_type (type);
1829 
1830  if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1831  return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1832  else
1833  return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
1834 }
1835 
1836 /* If TYPE is the type of an array-bounds structure, the type of its
1837  Ith bound (numbering from 1). Otherwise, NULL. */
1838 
1839 static struct type *
1840 desc_index_type (struct type *type, int i)
1841 {
1842  type = desc_base_type (type);
1843 
1844  if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1845  return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1846  else
1847  return NULL;
1848 }
1849 
1850 /* The number of index positions in the array-bounds type TYPE.
1851  Return 0 if TYPE is NULL. */
1852 
1853 static int
1855 {
1856  type = desc_base_type (type);
1857 
1858  if (type != NULL)
1859  return TYPE_NFIELDS (type) / 2;
1860  return 0;
1861 }
1862 
1863 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1864  an array descriptor type (representing an unconstrained array
1865  type). */
1866 
1867 static int
1869 {
1870  if (type == NULL)
1871  return 0;
1872  type = ada_check_typedef (type);
1873  return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1874  || ada_is_array_descriptor_type (type));
1875 }
1876 
1877 /* Non-zero iff TYPE represents any kind of array in Ada, or a pointer
1878  * to one. */
1879 
1880 static int
1882 {
1883  while (type != NULL
1884  && (TYPE_CODE (type) == TYPE_CODE_PTR
1885  || TYPE_CODE (type) == TYPE_CODE_REF))
1886  type = TYPE_TARGET_TYPE (type);
1887  return ada_is_direct_array_type (type);
1888 }
1889 
1890 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1891 
1892 int
1894 {
1895  if (type == NULL)
1896  return 0;
1897  type = ada_check_typedef (type);
1898  return (TYPE_CODE (type) == TYPE_CODE_ARRAY
1899  || (TYPE_CODE (type) == TYPE_CODE_PTR
1901  == TYPE_CODE_ARRAY));
1902 }
1903 
1904 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1905 
1906 int
1908 {
1909  struct type *data_type = desc_data_target_type (type);
1910 
1911  if (type == NULL)
1912  return 0;
1913  type = ada_check_typedef (type);
1914  return (data_type != NULL
1915  && TYPE_CODE (data_type) == TYPE_CODE_ARRAY
1916  && desc_arity (desc_bounds_type (type)) > 0);
1917 }
1918 
1919 /* Non-zero iff type is a partially mal-formed GNAT array
1920  descriptor. FIXME: This is to compensate for some problems with
1921  debugging output from GNAT. Re-examine periodically to see if it
1922  is still needed. */
1923 
1924 int
1926 {
1927  return
1928  type != NULL
1929  && TYPE_CODE (type) == TYPE_CODE_STRUCT
1930  && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
1931  || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1932  && !ada_is_array_descriptor_type (type);
1933 }
1934 
1935 
1936 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1937  (fat pointer) returns the type of the array data described---specifically,
1938  a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1939  in from the descriptor; otherwise, they are left unspecified. If
1940  the ARR denotes a null array descriptor and BOUNDS is non-zero,
1941  returns NULL. The result is simply the type of ARR if ARR is not
1942  a descriptor. */
1943 struct type *
1944 ada_type_of_array (struct value *arr, int bounds)
1945 {
1948 
1950  return value_type (arr);
1951 
1952  if (!bounds)
1953  {
1954  struct type *array_type =
1956 
1958  TYPE_FIELD_BITSIZE (array_type, 0) =
1960 
1961  return array_type;
1962  }
1963  else
1964  {
1965  struct type *elt_type;
1966  int arity;
1967  struct value *descriptor;
1968 
1969  elt_type = ada_array_element_type (value_type (arr), -1);
1970  arity = ada_array_arity (value_type (arr));
1971 
1972  if (elt_type == NULL || arity == 0)
1973  return ada_check_typedef (value_type (arr));
1974 
1975  descriptor = desc_bounds (arr);
1976  if (value_as_long (descriptor) == 0)
1977  return NULL;
1978  while (arity > 0)
1979  {
1980  struct type *range_type = alloc_type_copy (value_type (arr));
1981  struct type *array_type = alloc_type_copy (value_type (arr));
1982  struct value *low = desc_one_bound (descriptor, arity, 0);
1983  struct value *high = desc_one_bound (descriptor, arity, 1);
1984 
1985  arity -= 1;
1986  create_static_range_type (range_type, value_type (low),
1987  longest_to_int (value_as_long (low)),
1988  longest_to_int (value_as_long (high)));
1989  elt_type = create_array_type (array_type, elt_type, range_type);
1990 
1992  {
1993  /* We need to store the element packed bitsize, as well as
1994  recompute the array size, because it was previously
1995  computed based on the unpacked element size. */
1996  LONGEST lo = value_as_long (low);
1997  LONGEST hi = value_as_long (high);
1998 
1999  TYPE_FIELD_BITSIZE (elt_type, 0) =
2001  /* If the array has no element, then the size is already
2002  zero, and does not need to be recomputed. */
2003  if (lo < hi)
2004  {
2005  int array_bitsize =
2006  (hi - lo + 1) * TYPE_FIELD_BITSIZE (elt_type, 0);
2007 
2008  TYPE_LENGTH (array_type) = (array_bitsize + 7) / 8;
2009  }
2010  }
2011  }
2012 
2013  return lookup_pointer_type (elt_type);
2014  }
2015 }
2016 
2017 /* If ARR does not represent an array, returns ARR unchanged.
2018  Otherwise, returns either a standard GDB array with bounds set
2019  appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
2020  GDB array. Returns NULL if ARR is a null fat pointer. */
2021 
2022 struct value *
2024 {
2026  {
2027  struct type *arrType = ada_type_of_array (arr, 1);
2028 
2029  if (arrType == NULL)
2030  return NULL;
2031  return value_cast (arrType, value_copy (desc_data (arr)));
2032  }
2034  return decode_constrained_packed_array (arr);
2035  else
2036  return arr;
2037 }
2038 
2039 /* If ARR does not represent an array, returns ARR unchanged.
2040  Otherwise, returns a standard GDB array describing ARR (which may
2041  be ARR itself if it already is in the proper form). */
2042 
2043 struct value *
2045 {
2047  {
2048  struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
2049 
2050  if (arrVal == NULL)
2051  error (_("Bounds unavailable for null array pointer."));
2053  return value_ind (arrVal);
2054  }
2056  return decode_constrained_packed_array (arr);
2057  else
2058  return arr;
2059 }
2060 
2061 /* If TYPE represents a GNAT array type, return it translated to an
2062  ordinary GDB array type (possibly with BITSIZE fields indicating
2063  packing). For other types, is the identity. */
2064 
2065 struct type *
2067 {
2070 
2071  if (ada_is_array_descriptor_type (type))
2072  return ada_check_typedef (desc_data_target_type (type));
2073 
2074  return type;
2075 }
2076 
2077 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
2078 
2079 static int
2081 {
2082  if (type == NULL)
2083  return 0;
2084  type = desc_base_type (type);
2085  type = ada_check_typedef (type);
2086  return
2087  ada_type_name (type) != NULL
2088  && strstr (ada_type_name (type), "___XP") != NULL;
2089 }
2090 
2091 /* Non-zero iff TYPE represents a standard GNAT constrained
2092  packed-array type. */
2093 
2094 int
2096 {
2097  return ada_is_packed_array_type (type)
2098  && !ada_is_array_descriptor_type (type);
2099 }
2100 
2101 /* Non-zero iff TYPE represents an array descriptor for a
2102  unconstrained packed-array type. */
2103 
2104 static int
2106 {
2107  return ada_is_packed_array_type (type)
2108  && ada_is_array_descriptor_type (type);
2109 }
2110 
2111 /* Given that TYPE encodes a packed array type (constrained or unconstrained),
2112  return the size of its elements in bits. */
2113 
2114 static long
2116 {
2117  const char *raw_name;
2118  const char *tail;
2119  long bits;
2120 
2121  /* Access to arrays implemented as fat pointers are encoded as a typedef
2122  of the fat pointer type. We need the name of the fat pointer type
2123  to do the decoding, so strip the typedef layer. */
2124  if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
2125  type = ada_typedef_target_type (type);
2126 
2127  raw_name = ada_type_name (ada_check_typedef (type));
2128  if (!raw_name)
2129  raw_name = ada_type_name (desc_base_type (type));
2130 
2131  if (!raw_name)
2132  return 0;
2133 
2134  tail = strstr (raw_name, "___XP");
2135  gdb_assert (tail != NULL);
2136 
2137  if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
2138  {
2139  lim_warning
2140  (_("could not understand bit size information on packed array"));
2141  return 0;
2142  }
2143 
2144  return bits;
2145 }
2146 
2147 /* Given that TYPE is a standard GDB array type with all bounds filled
2148  in, and that the element size of its ultimate scalar constituents
2149  (that is, either its elements, or, if it is an array of arrays, its
2150  elements' elements, etc.) is *ELT_BITS, return an identical type,
2151  but with the bit sizes of its elements (and those of any
2152  constituent arrays) recorded in the BITSIZE components of its
2153  TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
2154  in bits.
2155 
2156  Note that, for arrays whose index type has an XA encoding where
2157  a bound references a record discriminant, getting that discriminant,
2158  and therefore the actual value of that bound, is not possible
2159  because none of the given parameters gives us access to the record.
2160  This function assumes that it is OK in the context where it is being
2161  used to return an array whose bounds are still dynamic and where
2162  the length is arbitrary. */
2163 
2164 static struct type *
2165 constrained_packed_array_type (struct type *type, long *elt_bits)
2166 {
2167  struct type *new_elt_type;
2168  struct type *new_type;
2169  struct type *index_type_desc;
2170  struct type *index_type;
2171  LONGEST low_bound, high_bound;
2172 
2173  type = ada_check_typedef (type);
2174  if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2175  return type;
2176 
2177  index_type_desc = ada_find_parallel_type (type, "___XA");
2178  if (index_type_desc)
2179  index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, 0),
2180  NULL);
2181  else
2182  index_type = TYPE_INDEX_TYPE (type);
2183 
2184  new_type = alloc_type_copy (type);
2185  new_elt_type =
2187  elt_bits);
2188  create_array_type (new_type, new_elt_type, index_type);
2189  TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
2190  TYPE_NAME (new_type) = ada_type_name (type);
2191 
2192  if ((TYPE_CODE (check_typedef (index_type)) == TYPE_CODE_RANGE
2193  && is_dynamic_type (check_typedef (index_type)))
2194  || get_discrete_bounds (index_type, &low_bound, &high_bound) < 0)
2195  low_bound = high_bound = 0;
2196  if (high_bound < low_bound)
2197  *elt_bits = TYPE_LENGTH (new_type) = 0;
2198  else
2199  {
2200  *elt_bits *= (high_bound - low_bound + 1);
2201  TYPE_LENGTH (new_type) =
2202  (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2203  }
2204 
2205  TYPE_FIXED_INSTANCE (new_type) = 1;
2206  return new_type;
2207 }
2208 
2209 /* The array type encoded by TYPE, where
2210  ada_is_constrained_packed_array_type (TYPE). */
2211 
2212 static struct type *
2214 {
2215  const char *raw_name = ada_type_name (ada_check_typedef (type));
2216  char *name;
2217  const char *tail;
2218  struct type *shadow_type;
2219  long bits;
2220 
2221  if (!raw_name)
2222  raw_name = ada_type_name (desc_base_type (type));
2223 
2224  if (!raw_name)
2225  return NULL;
2226 
2227  name = (char *) alloca (strlen (raw_name) + 1);
2228  tail = strstr (raw_name, "___XP");
2229  type = desc_base_type (type);
2230 
2231  memcpy (name, raw_name, tail - raw_name);
2232  name[tail - raw_name] = '\000';
2233 
2234  shadow_type = ada_find_parallel_type_with_name (type, name);
2235 
2236  if (shadow_type == NULL)
2237  {
2238  lim_warning (_("could not find bounds information on packed array"));
2239  return NULL;
2240  }
2241  CHECK_TYPEDEF (shadow_type);
2242 
2243  if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
2244  {
2245  lim_warning (_("could not understand bounds "
2246  "information on packed array"));
2247  return NULL;
2248  }
2249 
2250  bits = decode_packed_array_bitsize (type);
2251  return constrained_packed_array_type (shadow_type, &bits);
2252 }
2253 
2254 /* Given that ARR is a struct value *indicating a GNAT constrained packed
2255  array, returns a simple array that denotes that array. Its type is a
2256  standard GDB array type except that the BITSIZEs of the array
2257  target types are set to the number of bits in each element, and the
2258  type length is set appropriately. */
2259 
2260 static struct value *
2262 {
2263  struct type *type;
2264 
2265  /* If our value is a pointer, then dereference it. Likewise if
2266  the value is a reference. Make sure that this operation does not
2267  cause the target type to be fixed, as this would indirectly cause
2268  this array to be decoded. The rest of the routine assumes that
2269  the array hasn't been decoded yet, so we use the basic "coerce_ref"
2270  and "value_ind" routines to perform the dereferencing, as opposed
2271  to using "ada_coerce_ref" or "ada_value_ind". */
2272  arr = coerce_ref (arr);
2274  arr = value_ind (arr);
2275 
2277  if (type == NULL)
2278  {
2279  error (_("can't unpack array"));
2280  return NULL;
2281  }
2282 
2284  && ada_is_modular_type (value_type (arr)))
2285  {
2286  /* This is a (right-justified) modular type representing a packed
2287  array with no wrapper. In order to interpret the value through
2288  the (left-justified) packed array type we just built, we must
2289  first left-justify it. */
2290  int bit_size, bit_pos;
2291  ULONGEST mod;
2292 
2293  mod = ada_modulus (value_type (arr)) - 1;
2294  bit_size = 0;
2295  while (mod > 0)
2296  {
2297  bit_size += 1;
2298  mod >>= 1;
2299  }
2300  bit_pos = HOST_CHAR_BIT * TYPE_LENGTH (value_type (arr)) - bit_size;
2301  arr = ada_value_primitive_packed_val (arr, NULL,
2302  bit_pos / HOST_CHAR_BIT,
2303  bit_pos % HOST_CHAR_BIT,
2304  bit_size,
2305  type);
2306  }
2307 
2308  return coerce_unspec_val_to_type (arr, type);
2309 }
2310 
2311 
2312 /* The value of the element of packed array ARR at the ARITY indices
2313  given in IND. ARR must be a simple array. */
2314 
2315 static struct value *
2316 value_subscript_packed (struct value *arr, int arity, struct value **ind)
2317 {
2318  int i;
2319  int bits, elt_off, bit_off;
2320  long elt_total_bit_offset;
2321  struct type *elt_type;
2322  struct value *v;
2323 
2324  bits = 0;
2325  elt_total_bit_offset = 0;
2326  elt_type = ada_check_typedef (value_type (arr));
2327  for (i = 0; i < arity; i += 1)
2328  {
2329  if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
2330  || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
2331  error
2332  (_("attempt to do packed indexing of "
2333  "something other than a packed array"));
2334  else
2335  {
2336  struct type *range_type = TYPE_INDEX_TYPE (elt_type);
2337  LONGEST lowerbound, upperbound;
2338  LONGEST idx;
2339 
2340  if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
2341  {
2342  lim_warning (_("don't know bounds of array"));
2343  lowerbound = upperbound = 0;
2344  }
2345 
2346  idx = pos_atr (ind[i]);
2347  if (idx < lowerbound || idx > upperbound)
2348  lim_warning (_("packed array index %ld out of bounds"),
2349  (long) idx);
2350  bits = TYPE_FIELD_BITSIZE (elt_type, 0);
2351  elt_total_bit_offset += (idx - lowerbound) * bits;
2352  elt_type = ada_check_typedef (TYPE_TARGET_TYPE (elt_type));
2353  }
2354  }
2355  elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
2356  bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
2357 
2358  v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
2359  bits, elt_type);
2360  return v;
2361 }
2362 
2363 /* Non-zero iff TYPE includes negative integer values. */
2364 
2365 static int
2367 {
2368  switch (TYPE_CODE (type))
2369  {
2370  default:
2371  return 0;
2372  case TYPE_CODE_INT:
2373  return !TYPE_UNSIGNED (type);
2374  case TYPE_CODE_RANGE:
2375  return TYPE_LOW_BOUND (type) < 0;
2376  }
2377 }
2378 
2379 
2380 /* Create a new value of type TYPE from the contents of OBJ starting
2381  at byte OFFSET, and bit offset BIT_OFFSET within that byte,
2382  proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
2383  assigning through the result will set the field fetched from.
2384  VALADDR is ignored unless OBJ is NULL, in which case,
2385  VALADDR+OFFSET must address the start of storage containing the
2386  packed value. The value returned in this case is never an lval.
2387  Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
2388 
2389 struct value *
2390 ada_value_primitive_packed_val (struct value *obj, const gdb_byte *valaddr,
2391  long offset, int bit_offset, int bit_size,
2392  struct type *type)
2393 {
2394  struct value *v;
2395  int src, /* Index into the source area */
2396  targ, /* Index into the target area */
2397  srcBitsLeft, /* Number of source bits left to move */
2398  nsrc, ntarg, /* Number of source and target bytes */
2399  unusedLS, /* Number of bits in next significant
2400  byte of source that are unused */
2401  accumSize; /* Number of meaningful bits in accum */
2402  unsigned char *bytes; /* First byte containing data to unpack */
2403  unsigned char *unpacked;
2404  unsigned long accum; /* Staging area for bits being transferred */
2405  unsigned char sign;
2406  int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
2407  /* Transmit bytes from least to most significant; delta is the direction
2408  the indices move. */
2409  int delta = gdbarch_bits_big_endian (get_type_arch (type)) ? -1 : 1;
2410 
2411  type = ada_check_typedef (type);
2412 
2413  if (obj == NULL)
2414  {
2415  v = allocate_value (type);
2416  bytes = (unsigned char *) (valaddr + offset);
2417  }
2418  else if (VALUE_LVAL (obj) == lval_memory && value_lazy (obj))
2419  {
2420  v = value_at (type, value_address (obj) + offset);
2421  type = value_type (v);
2422  if (TYPE_LENGTH (type) * HOST_CHAR_BIT < bit_size)
2423  {
2424  /* This can happen in the case of an array of dynamic objects,
2425  where the size of each element changes from element to element.
2426  In that case, we're initially given the array stride, but
2427  after resolving the element type, we find that its size is
2428  less than this stride. In that case, adjust bit_size to
2429  match TYPE's length, and recompute LEN accordingly. */
2430  bit_size = TYPE_LENGTH (type) * HOST_CHAR_BIT;
2431  len = TYPE_LENGTH (type) + (bit_offset + HOST_CHAR_BIT - 1) / 8;
2432  }
2433  bytes = (unsigned char *) alloca (len);
2434  read_memory (value_address (v), bytes, len);
2435  }
2436  else
2437  {
2438  v = allocate_value (type);
2439  bytes = (unsigned char *) value_contents (obj) + offset;
2440  }
2441 
2442  if (obj != NULL)
2443  {
2444  long new_offset = offset;
2445 
2447  set_value_bitpos (v, bit_offset + value_bitpos (obj));
2448  set_value_bitsize (v, bit_size);
2449  if (value_bitpos (v) >= HOST_CHAR_BIT)
2450  {
2451  ++new_offset;
2453  }
2454  set_value_offset (v, new_offset);
2455 
2456  /* Also set the parent value. This is needed when trying to
2457  assign a new value (in inferior memory). */
2458  set_value_parent (v, obj);
2459  }
2460  else
2461  set_value_bitsize (v, bit_size);
2462  unpacked = (unsigned char *) value_contents (v);
2463 
2464  srcBitsLeft = bit_size;
2465  nsrc = len;
2466  ntarg = TYPE_LENGTH (type);
2467  sign = 0;
2468  if (bit_size == 0)
2469  {
2470  memset (unpacked, 0, TYPE_LENGTH (type));
2471  return v;
2472  }
2473  else if (gdbarch_bits_big_endian (get_type_arch (type)))
2474  {
2475  src = len - 1;
2476  if (has_negatives (type)
2477  && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
2478  sign = ~0;
2479 
2480  unusedLS =
2481  (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
2482  % HOST_CHAR_BIT;
2483 
2484  switch (TYPE_CODE (type))
2485  {
2486  case TYPE_CODE_ARRAY:
2487  case TYPE_CODE_UNION:
2488  case TYPE_CODE_STRUCT:
2489  /* Non-scalar values must be aligned at a byte boundary... */
2490  accumSize =
2491  (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
2492  /* ... And are placed at the beginning (most-significant) bytes
2493  of the target. */
2494  targ = (bit_size + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT - 1;
2495  ntarg = targ + 1;
2496  break;
2497  default:
2498  accumSize = 0;
2499  targ = TYPE_LENGTH (type) - 1;
2500  break;
2501  }
2502  }
2503  else
2504  {
2505  int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
2506 
2507  src = targ = 0;
2508  unusedLS = bit_offset;
2509  accumSize = 0;
2510 
2511  if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
2512  sign = ~0;
2513  }
2514 
2515  accum = 0;
2516  while (nsrc > 0)
2517  {
2518  /* Mask for removing bits of the next source byte that are not
2519  part of the value. */
2520  unsigned int unusedMSMask =
2521  (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
2522  1;
2523  /* Sign-extend bits for this byte. */
2524  unsigned int signMask = sign & ~unusedMSMask;
2525 
2526  accum |=
2527  (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
2528  accumSize += HOST_CHAR_BIT - unusedLS;
2529  if (accumSize >= HOST_CHAR_BIT)
2530  {
2531  unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2532  accumSize -= HOST_CHAR_BIT;
2533  accum >>= HOST_CHAR_BIT;
2534  ntarg -= 1;
2535  targ += delta;
2536  }
2537  srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
2538  unusedLS = 0;
2539  nsrc -= 1;
2540  src += delta;
2541  }
2542  while (ntarg > 0)
2543  {
2544  accum |= sign << accumSize;
2545  unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
2546  accumSize -= HOST_CHAR_BIT;
2547  if (accumSize < 0)
2548  accumSize = 0;
2549  accum >>= HOST_CHAR_BIT;
2550  ntarg -= 1;
2551  targ += delta;
2552  }
2553 
2554  if (is_dynamic_type (value_type (v)))
2556  0);
2557  return v;
2558 }
2559 
2560 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
2561  TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2562  not overlap. */
2563 static void
2564 move_bits (gdb_byte *target, int targ_offset, const gdb_byte *source,
2565  int src_offset, int n, int bits_big_endian_p)
2566 {
2567  unsigned int accum, mask;
2568  int accum_bits, chunk_size;
2569 
2570  target += targ_offset / HOST_CHAR_BIT;
2571  targ_offset %= HOST_CHAR_BIT;
2572  source += src_offset / HOST_CHAR_BIT;
2573  src_offset %= HOST_CHAR_BIT;
2574  if (bits_big_endian_p)
2575  {
2576  accum = (unsigned char) *source;
2577  source += 1;
2578  accum_bits = HOST_CHAR_BIT - src_offset;
2579 
2580  while (n > 0)
2581  {
2582  int unused_right;
2583 
2584  accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2585  accum_bits += HOST_CHAR_BIT;
2586  source += 1;
2587  chunk_size = HOST_CHAR_BIT - targ_offset;
2588  if (chunk_size > n)
2589  chunk_size = n;
2590  unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2591  mask = ((1 << chunk_size) - 1) << unused_right;
2592  *target =
2593  (*target & ~mask)
2594  | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2595  n -= chunk_size;
2596  accum_bits -= chunk_size;
2597  target += 1;
2598  targ_offset = 0;
2599  }
2600  }
2601  else
2602  {
2603  accum = (unsigned char) *source >> src_offset;
2604  source += 1;
2605  accum_bits = HOST_CHAR_BIT - src_offset;
2606 
2607  while (n > 0)
2608  {
2609  accum = accum + ((unsigned char) *source << accum_bits);
2610  accum_bits += HOST_CHAR_BIT;
2611  source += 1;
2612  chunk_size = HOST_CHAR_BIT - targ_offset;
2613  if (chunk_size > n)
2614  chunk_size = n;
2615  mask = ((1 << chunk_size) - 1) << targ_offset;
2616  *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2617  n -= chunk_size;
2618  accum_bits -= chunk_size;
2619  accum >>= chunk_size;
2620  target += 1;
2621  targ_offset = 0;
2622  }
2623  }
2624 }
2625 
2626 /* Store the contents of FROMVAL into the location of TOVAL.
2627  Return a new value with the location of TOVAL and contents of
2628  FROMVAL. Handles assignment into packed fields that have
2629  floating-point or non-scalar types. */
2630 
2631 static struct value *
2632 ada_value_assign (struct value *toval, struct value *fromval)
2633 {
2634  struct type *type = value_type (toval);
2635  int bits = value_bitsize (toval);
2636 
2637  toval = ada_coerce_ref (toval);
2638  fromval = ada_coerce_ref (fromval);
2639 
2640  if (ada_is_direct_array_type (value_type (toval)))
2641  toval = ada_coerce_to_simple_array (toval);
2642  if (ada_is_direct_array_type (value_type (fromval)))
2643  fromval = ada_coerce_to_simple_array (fromval);
2644 
2645  if (!deprecated_value_modifiable (toval))
2646  error (_("Left operand of assignment is not a modifiable lvalue."));
2647 
2648  if (VALUE_LVAL (toval) == lval_memory
2649  && bits > 0
2650  && (TYPE_CODE (type) == TYPE_CODE_FLT
2651  || TYPE_CODE (type) == TYPE_CODE_STRUCT))
2652  {
2653  int len = (value_bitpos (toval)
2654  + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
2655  int from_size;
2656  gdb_byte *buffer = alloca (len);
2657  struct value *val;
2658  CORE_ADDR to_addr = value_address (toval);
2659 
2660  if (TYPE_CODE (type) == TYPE_CODE_FLT)
2661  fromval = value_cast (type, fromval);
2662 
2663  read_memory (to_addr, buffer, len);
2664  from_size = value_bitsize (fromval);
2665  if (from_size == 0)
2666  from_size = TYPE_LENGTH (value_type (fromval)) * TARGET_CHAR_BIT;
2668  move_bits (buffer, value_bitpos (toval),
2669  value_contents (fromval), from_size - bits, bits, 1);
2670  else
2671  move_bits (buffer, value_bitpos (toval),
2672  value_contents (fromval), 0, bits, 0);
2673  write_memory_with_notification (to_addr, buffer, len);
2674 
2675  val = value_copy (toval);
2676  memcpy (value_contents_raw (val), value_contents (fromval),
2677  TYPE_LENGTH (type));
2678  deprecated_set_value_type (val, type);
2679 
2680  return val;
2681  }
2682 
2683  return value_assign (toval, fromval);
2684 }
2685 
2686 
2687 /* Given that COMPONENT is a memory lvalue that is part of the lvalue
2688  CONTAINER, assign the contents of VAL to COMPONENTS's place in
2689  CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not
2690  COMPONENT, and not the inferior's memory. The current contents
2691  of COMPONENT are ignored.
2692 
2693  Although not part of the initial design, this function also works
2694  when CONTAINER and COMPONENT are not_lval's: it works as if CONTAINER
2695  had a null address, and COMPONENT had an address which is equal to
2696  its offset inside CONTAINER. */
2697 
2698 static void
2699 value_assign_to_component (struct value *container, struct value *component,
2700  struct value *val)
2701 {
2702  LONGEST offset_in_container =
2703  (LONGEST) (value_address (component) - value_address (container));
2704  int bit_offset_in_container =
2705  value_bitpos (component) - value_bitpos (container);
2706  int bits;
2707 
2708  val = value_cast (value_type (component), val);
2709 
2710  if (value_bitsize (component) == 0)
2711  bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component));
2712  else
2713  bits = value_bitsize (component);
2714 
2715  if (gdbarch_bits_big_endian (get_type_arch (value_type (container))))
2716  move_bits (value_contents_writeable (container) + offset_in_container,
2717  value_bitpos (container) + bit_offset_in_container,
2718  value_contents (val),
2719  TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits,
2720  bits, 1);
2721  else
2722  move_bits (value_contents_writeable (container) + offset_in_container,
2723  value_bitpos (container) + bit_offset_in_container,
2724  value_contents (val), 0, bits, 0);
2725 }
2726 
2727 /* The value of the element of array ARR at the ARITY indices given in IND.
2728  ARR may be either a simple array, GNAT array descriptor, or pointer
2729  thereto. */
2730 
2731 struct value *
2732 ada_value_subscript (struct value *arr, int arity, struct value **ind)
2733 {
2734  int k;
2735  struct value *elt;
2736  struct type *elt_type;
2737 
2738  elt = ada_coerce_to_simple_array (arr);
2739 
2740  elt_type = ada_check_typedef (value_type (elt));
2741  if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
2742  && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2743  return value_subscript_packed (elt, arity, ind);
2744 
2745  for (k = 0; k < arity; k += 1)
2746  {
2747  if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
2748  error (_("too many subscripts (%d expected)"), k);
2749  elt = value_subscript (elt, pos_atr (ind[k]));
2750  }
2751  return elt;
2752 }
2753 
2754 /* Assuming ARR is a pointer to a GDB array, the value of the element
2755  of *ARR at the ARITY indices given in IND.
2756  Does not read the entire array into memory. */
2757 
2758 static struct value *
2759 ada_value_ptr_subscript (struct value *arr, int arity, struct value **ind)
2760 {
2761  int k;
2762  struct type *type
2764 
2765  for (k = 0; k < arity; k += 1)
2766  {
2767  LONGEST lwb, upb;
2768  struct value *lwb_value;
2769 
2770  if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2771  error (_("too many subscripts (%d expected)"), k);
2773  value_copy (arr));
2774  get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
2775  lwb_value = value_from_longest (value_type(ind[k]), lwb);
2776  arr = value_ptradd (arr, pos_atr (ind[k]) - pos_atr (lwb_value));
2777  type = TYPE_TARGET_TYPE (type);
2778  }
2779 
2780  return value_ind (arr);
2781 }
2782 
2783 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2784  actual type of ARRAY_PTR is ignored), returns the Ada slice of
2785  HIGH'Pos-LOW'Pos+1 elements starting at index LOW. The lower bound of
2786  this array is LOW, as per Ada rules. */
2787 static struct value *
2788 ada_value_slice_from_ptr (struct value *array_ptr, struct type *type,
2789  int low, int high)
2790 {
2791  struct type *type0 = ada_check_typedef (type);
2792  struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type0));
2793  struct type *index_type
2794  = create_static_range_type (NULL, base_index_type, low, high);
2795  struct type *slice_type =
2796  create_array_type (NULL, TYPE_TARGET_TYPE (type0), index_type);
2797  int base_low = ada_discrete_type_low_bound (TYPE_INDEX_TYPE (type0));
2798  LONGEST base_low_pos, low_pos;
2799  CORE_ADDR base;
2800 
2801  if (!discrete_position (base_index_type, low, &low_pos)
2802  || !discrete_position (base_index_type, base_low, &base_low_pos))
2803  {
2804  warning (_("unable to get positions in slice, use bounds instead"));
2805  low_pos = low;
2806  base_low_pos = base_low;
2807  }
2808 
2809  base = value_as_address (array_ptr)
2810  + ((low_pos - base_low_pos)
2811  * TYPE_LENGTH (TYPE_TARGET_TYPE (type0)));
2812  return value_at_lazy (slice_type, base);
2813 }
2814 
2815 
2816 static struct value *
2817 ada_value_slice (struct value *array, int low, int high)
2818 {
2819  struct type *type = ada_check_typedef (value_type (array));
2820  struct type *base_index_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2821  struct type *index_type
2822  = create_static_range_type (NULL, TYPE_INDEX_TYPE (type), low, high);
2823  struct type *slice_type =
2824  create_array_type (NULL, TYPE_TARGET_TYPE (type), index_type);
2825  LONGEST low_pos, high_pos;
2826 
2827  if (!discrete_position (base_index_type, low, &low_pos)
2828  || !discrete_position (base_index_type, high, &high_pos))
2829  {
2830  warning (_("unable to get positions in slice, use bounds instead"));
2831  low_pos = low;
2832  high_pos = high;
2833  }
2834 
2835  return value_cast (slice_type,
2836  value_slice (array, low, high_pos - low_pos + 1));
2837 }
2838 
2839 /* If type is a record type in the form of a standard GNAT array
2840  descriptor, returns the number of dimensions for type. If arr is a
2841  simple array, returns the number of "array of"s that prefix its
2842  type designation. Otherwise, returns 0. */
2843 
2844 int
2846 {
2847  int arity;
2848 
2849  if (type == NULL)
2850  return 0;
2851 
2852  type = desc_base_type (type);
2853 
2854  arity = 0;
2855  if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2856  return desc_arity (desc_bounds_type (type));
2857  else
2858  while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2859  {
2860  arity += 1;
2861  type = ada_check_typedef (TYPE_TARGET_TYPE (type));
2862  }
2863 
2864  return arity;
2865 }
2866 
2867 /* If TYPE is a record type in the form of a standard GNAT array
2868  descriptor or a simple array type, returns the element type for
2869  TYPE after indexing by NINDICES indices, or by all indices if
2870  NINDICES is -1. Otherwise, returns NULL. */
2871 
2872 struct type *
2873 ada_array_element_type (struct type *type, int nindices)
2874 {
2875  type = desc_base_type (type);
2876 
2877  if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
2878  {
2879  int k;
2880  struct type *p_array_type;
2881 
2882  p_array_type = desc_data_target_type (type);
2883 
2884  k = ada_array_arity (type);
2885  if (k == 0)
2886  return NULL;
2887 
2888  /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2889  if (nindices >= 0 && k > nindices)
2890  k = nindices;
2891  while (k > 0 && p_array_type != NULL)
2892  {
2893  p_array_type = ada_check_typedef (TYPE_TARGET_TYPE (p_array_type));
2894  k -= 1;
2895  }
2896  return p_array_type;
2897  }
2898  else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2899  {
2900  while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
2901  {
2902  type = TYPE_TARGET_TYPE (type);
2903  nindices -= 1;
2904  }
2905  return type;
2906  }
2907 
2908  return NULL;
2909 }
2910 
2911 /* The type of nth index in arrays of given type (n numbering from 1).
2912  Does not examine memory. Throws an error if N is invalid or TYPE
2913  is not an array type. NAME is the name of the Ada attribute being
2914  evaluated ('range, 'first, 'last, or 'length); it is used in building
2915  the error message. */
2916 
2917 static struct type *
2918 ada_index_type (struct type *type, int n, const char *name)
2919 {
2920  struct type *result_type;
2921 
2922  type = desc_base_type (type);
2923 
2924  if (n < 0 || n > ada_array_arity (type))
2925  error (_("invalid dimension number to '%s"), name);
2926 
2927  if (ada_is_simple_array_type (type))
2928  {
2929  int i;
2930 
2931  for (i = 1; i < n; i += 1)
2932  type = TYPE_TARGET_TYPE (type);
2933  result_type = TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type));
2934  /* FIXME: The stabs type r(0,0);bound;bound in an array type
2935  has a target type of TYPE_CODE_UNDEF. We compensate here, but
2936  perhaps stabsread.c would make more sense. */
2937  if (result_type && TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2938  result_type = NULL;
2939  }
2940  else
2941  {
2942  result_type = desc_index_type (desc_bounds_type (type), n);
2943  if (result_type == NULL)
2944  error (_("attempt to take bound of something that is not an array"));
2945  }
2946 
2947  return result_type;
2948 }
2949 
2950 /* Given that arr is an array type, returns the lower bound of the
2951  Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2952  WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2953  array-descriptor type. It works for other arrays with bounds supplied
2954  by run-time quantities other than discriminants. */
2955 
2956 static LONGEST
2957 ada_array_bound_from_type (struct type *arr_type, int n, int which)
2958 {
2959  struct type *type, *index_type_desc, *index_type;
2960  int i;
2961 
2962  gdb_assert (which == 0 || which == 1);
2963 
2964  if (ada_is_constrained_packed_array_type (arr_type))
2965  arr_type = decode_constrained_packed_array_type (arr_type);
2966 
2967  if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
2968  return (LONGEST) - which;
2969 
2970  if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2971  type = TYPE_TARGET_TYPE (arr_type);
2972  else
2973  type = arr_type;
2974 
2975  if (TYPE_FIXED_INSTANCE (type))
2976  {
2977  /* The array has already been fixed, so we do not need to
2978  check the parallel ___XA type again. That encoding has
2979  already been applied, so ignore it now. */
2980  index_type_desc = NULL;
2981  }
2982  else
2983  {
2984  index_type_desc = ada_find_parallel_type (type, "___XA");
2985  ada_fixup_array_indexes_type (index_type_desc);
2986  }
2987 
2988  if (index_type_desc != NULL)
2989  index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
2990  NULL);
2991  else
2992  {
2993  struct type *elt_type = check_typedef (type);
2994 
2995  for (i = 1; i < n; i++)
2996  elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
2997 
2998  index_type = TYPE_INDEX_TYPE (elt_type);
2999  }
3000 
3001  return
3002  (LONGEST) (which == 0
3003  ? ada_discrete_type_low_bound (index_type)
3004  : ada_discrete_type_high_bound (index_type));
3005 }
3006 
3007 /* Given that arr is an array value, returns the lower bound of the
3008  nth index (numbering from 1) if WHICH is 0, and the upper bound if
3009  WHICH is 1. This routine will also work for arrays with bounds
3010  supplied by run-time quantities other than discriminants. */
3011 
3012 static LONGEST
3013 ada_array_bound (struct value *arr, int n, int which)
3014 {
3015  struct type *arr_type;
3016 
3018  arr = value_ind (arr);
3019  arr_type = value_enclosing_type (arr);
3020 
3021  if (ada_is_constrained_packed_array_type (arr_type))
3022  return ada_array_bound (decode_constrained_packed_array (arr), n, which);
3023  else if (ada_is_simple_array_type (arr_type))
3024  return ada_array_bound_from_type (arr_type, n, which);
3025  else
3026  return value_as_long (desc_one_bound (desc_bounds (arr), n, which));
3027 }
3028 
3029 /* Given that arr is an array value, returns the length of the
3030  nth index. This routine will also work for arrays with bounds
3031  supplied by run-time quantities other than discriminants.
3032  Does not work for arrays indexed by enumeration types with representation
3033  clauses at the moment. */
3034 
3035 static LONGEST
3036 ada_array_length (struct value *arr, int n)
3037 {
3038  struct type *arr_type, *index_type;
3039  int low, high;
3040 
3042  arr = value_ind (arr);
3043  arr_type = value_enclosing_type (arr);
3044 
3045  if (ada_is_constrained_packed_array_type (arr_type))
3047 
3048  if (ada_is_simple_array_type (arr_type))
3049  {
3050  low = ada_array_bound_from_type (arr_type, n, 0);
3051  high = ada_array_bound_from_type (arr_type, n, 1);
3052  }
3053  else
3054  {
3055  low = value_as_long (desc_one_bound (desc_bounds (arr), n, 0));
3056  high = value_as_long (desc_one_bound (desc_bounds (arr), n, 1));
3057  }
3058 
3059  CHECK_TYPEDEF (arr_type);
3060  index_type = TYPE_INDEX_TYPE (arr_type);
3061  if (index_type != NULL)
3062  {
3063  struct type *base_type;
3064  if (TYPE_CODE (index_type) == TYPE_CODE_RANGE)
3065  base_type = TYPE_TARGET_TYPE (index_type);
3066  else
3067  base_type = index_type;
3068 
3069  low = pos_atr (value_from_longest (base_type, low));
3070  high = pos_atr (value_from_longest (base_type, high));
3071  }
3072  return high - low + 1;
3073 }
3074 
3075 /* An empty array whose type is that of ARR_TYPE (an array type),
3076  with bounds LOW to LOW-1. */
3077 
3078 static struct value *
3079 empty_array (struct type *arr_type, int low)
3080 {
3081  struct type *arr_type0 = ada_check_typedef (arr_type);
3082  struct type *index_type
3084  (NULL, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type0)), low, low - 1);
3085  struct type *elt_type = ada_array_element_type (arr_type0, 1);
3086 
3087  return allocate_value (create_array_type (NULL, elt_type, index_type));
3088 }
3089 
3090 
3091  /* Name resolution */
3092 
3093 /* The "decoded" name for the user-definable Ada operator corresponding
3094  to OP. */
3095 
3096 static const char *
3098 {
3099  int i;
3100 
3101  for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
3102  {
3103  if (ada_opname_table[i].op == op)
3104  return ada_opname_table[i].decoded;
3105  }
3106  error (_("Could not find operator name for opcode"));
3107 }
3108 
3109 
3110 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
3111  references (marked by OP_VAR_VALUE nodes in which the symbol has an
3112  undefined namespace) and converts operators that are
3113  user-defined into appropriate function calls. If CONTEXT_TYPE is
3114  non-null, it provides a preferred result type [at the moment, only
3115  type void has any effect---causing procedures to be preferred over
3116  functions in calls]. A null CONTEXT_TYPE indicates that a non-void
3117  return type is preferred. May change (expand) *EXP. */
3118 
3119 static void
3120 resolve (struct expression **expp, int void_context_p)
3121 {
3122  struct type *context_type = NULL;
3123  int pc = 0;
3124 
3125  if (void_context_p)
3126  context_type = builtin_type ((*expp)->gdbarch)->builtin_void;
3127 
3128  resolve_subexp (expp, &pc, 1, context_type);
3129 }
3130 
3131 /* Resolve the operator of the subexpression beginning at
3132  position *POS of *EXPP. "Resolving" consists of replacing
3133  the symbols that have undefined namespaces in OP_VAR_VALUE nodes
3134  with their resolutions, replacing built-in operators with
3135  function calls to user-defined operators, where appropriate, and,
3136  when DEPROCEDURE_P is non-zero, converting function-valued variables
3137  into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
3138  are as in ada_resolve, above. */
3139 
3140 static struct value *
3141 resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
3142  struct type *context_type)
3143 {
3144  int pc = *pos;
3145  int i;
3146  struct expression *exp; /* Convenience: == *expp. */
3147  enum exp_opcode op = (*expp)->elts[pc].opcode;
3148  struct value **argvec; /* Vector of operand types (alloca'ed). */
3149  int nargs; /* Number of operands. */
3150  int oplen;
3151 
3152  argvec = NULL;
3153  nargs = 0;
3154  exp = *expp;
3155 
3156  /* Pass one: resolve operands, saving their types and updating *pos,
3157  if needed. */
3158  switch (op)
3159  {
3160  case OP_FUNCALL:
3161  if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3162  && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3163  *pos += 7;
3164  else
3165  {
3166  *pos += 3;
3167  resolve_subexp (expp, pos, 0, NULL);
3168  }
3169  nargs = longest_to_int (exp->elts[pc + 1].longconst);
3170  break;
3171 
3172  case UNOP_ADDR:
3173  *pos += 1;
3174  resolve_subexp (expp, pos, 0, NULL);
3175  break;
3176 
3177  case UNOP_QUAL:
3178  *pos += 3;
3179  resolve_subexp (expp, pos, 1, check_typedef (exp->elts[pc + 1].type));
3180  break;
3181 
3182  case OP_ATR_MODULUS:
3183  case OP_ATR_SIZE:
3184  case OP_ATR_TAG:
3185  case OP_ATR_FIRST:
3186  case OP_ATR_LAST:
3187  case OP_ATR_LENGTH:
3188  case OP_ATR_POS:
3189  case OP_ATR_VAL:
3190  case OP_ATR_MIN:
3191  case OP_ATR_MAX:
3192  case TERNOP_IN_RANGE:
3193  case BINOP_IN_BOUNDS:
3194  case UNOP_IN_RANGE:
3195  case OP_AGGREGATE:
3196  case OP_OTHERS:
3197  case OP_CHOICES:
3198  case OP_POSITIONAL:
3199  case OP_DISCRETE_RANGE:
3200  case OP_NAME:
3201  ada_forward_operator_length (exp, pc, &oplen, &nargs);
3202  *pos += oplen;
3203  break;
3204 
3205  case BINOP_ASSIGN:
3206  {
3207  struct value *arg1;
3208 
3209  *pos += 1;
3210  arg1 = resolve_subexp (expp, pos, 0, NULL);
3211  if (arg1 == NULL)
3212  resolve_subexp (expp, pos, 1, NULL);
3213  else
3214  resolve_subexp (expp, pos, 1, value_type (arg1));
3215  break;
3216  }
3217 
3218  case UNOP_CAST:
3219  *pos += 3;
3220  nargs = 1;
3221  break;
3222 
3223  case BINOP_ADD:
3224  case BINOP_SUB:
3225  case BINOP_MUL:
3226  case BINOP_DIV:
3227  case BINOP_REM:
3228  case BINOP_MOD:
3229  case BINOP_EXP:
3230  case BINOP_CONCAT:
3231  case BINOP_LOGICAL_AND:
3232  case BINOP_LOGICAL_OR:
3233  case BINOP_BITWISE_AND:
3234  case BINOP_BITWISE_IOR:
3235  case BINOP_BITWISE_XOR:
3236 
3237  case BINOP_EQUAL:
3238  case BINOP_NOTEQUAL:
3239  case BINOP_LESS:
3240  case BINOP_GTR:
3241  case BINOP_LEQ:
3242  case BINOP_GEQ:
3243 
3244  case BINOP_REPEAT:
3245  case BINOP_SUBSCRIPT:
3246  case BINOP_COMMA:
3247  *pos += 1;
3248  nargs = 2;
3249  break;
3250 
3251  case UNOP_NEG:
3252  case UNOP_PLUS:
3253  case UNOP_LOGICAL_NOT:
3254  case UNOP_ABS:
3255  case UNOP_IND:
3256  *pos += 1;
3257  nargs = 1;
3258  break;
3259 
3260  case OP_LONG:
3261  case OP_DOUBLE:
3262  case OP_VAR_VALUE:
3263  *pos += 4;
3264  break;
3265 
3266  case OP_TYPE:
3267  case OP_BOOL:
3268  case OP_LAST:
3269  case OP_INTERNALVAR:
3270  *pos += 3;
3271  break;
3272 
3273  case UNOP_MEMVAL:
3274  *pos += 3;
3275  nargs = 1;
3276  break;
3277 
3278  case OP_REGISTER:
3279  *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3280  break;
3281 
3282  case STRUCTOP_STRUCT:
3283  *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
3284  nargs = 1;
3285  break;
3286 
3287  case TERNOP_SLICE:
3288  *pos += 1;
3289  nargs = 3;
3290  break;
3291 
3292  case OP_STRING:
3293  break;
3294 
3295  default:
3296  error (_("Unexpected operator during name resolution"));
3297  }
3298 
3299  argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
3300  for (i = 0; i < nargs; i += 1)
3301  argvec[i] = resolve_subexp (expp, pos, 1, NULL);
3302  argvec[i] = NULL;
3303  exp = *expp;
3304 
3305  /* Pass two: perform any resolution on principal operator. */
3306  switch (op)
3307  {
3308  default:
3309  break;
3310 
3311  case OP_VAR_VALUE:
3312  if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
3313  {
3314  struct ada_symbol_info *candidates;
3315  int n_candidates;
3316 
3317  n_candidates =
3319  (exp->elts[pc + 2].symbol),
3320  exp->elts[pc + 1].block, VAR_DOMAIN,
3321  &candidates);
3322 
3323  if (n_candidates > 1)
3324  {
3325  /* Types tend to get re-introduced locally, so if there
3326  are any local symbols that are not types, first filter
3327  out all types. */
3328  int j;
3329  for (j = 0; j < n_candidates; j += 1)
3330  switch (SYMBOL_CLASS (candidates[j].sym))
3331  {
3332  case LOC_REGISTER:
3333  case LOC_ARG:
3334  case LOC_REF_ARG:
3335  case LOC_REGPARM_ADDR:
3336  case LOC_LOCAL:
3337  case LOC_COMPUTED:
3338  goto FoundNonType;
3339  default:
3340  break;
3341  }
3342  FoundNonType:
3343  if (j < n_candidates)
3344  {
3345  j = 0;
3346  while (j < n_candidates)
3347  {
3348  if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
3349  {
3350  candidates[j] = candidates[n_candidates - 1];
3351  n_candidates -= 1;
3352  }
3353  else
3354  j += 1;
3355  }
3356  }
3357  }
3358 
3359  if (n_candidates == 0)
3360  error (_("No definition found for %s"),
3361  SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3362  else if (n_candidates == 1)
3363  i = 0;
3364  else if (deprocedure_p
3365  && !is_nonfunction (candidates, n_candidates))
3366  {
3368  (candidates, n_candidates, NULL, 0,
3369  SYMBOL_LINKAGE_NAME (exp->elts[pc + 2].symbol),
3370  context_type);
3371  if (i < 0)
3372  error (_("Could not find a match for %s"),
3373  SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3374  }
3375  else
3376  {
3377  printf_filtered (_("Multiple matches for %s\n"),
3378  SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
3379  user_select_syms (candidates, n_candidates, 1);
3380  i = 0;
3381  }
3382 
3383  exp->elts[pc + 1].block = candidates[i].block;
3384  exp->elts[pc + 2].symbol = candidates[i].sym;
3385  if (innermost_block == NULL
3386  || contained_in (candidates[i].block, innermost_block))
3387  innermost_block = candidates[i].block;
3388  }
3389 
3390  if (deprocedure_p
3391  && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
3392  == TYPE_CODE_FUNC))
3393  {
3394  replace_operator_with_call (expp, pc, 0, 0,
3395  exp->elts[pc + 2].symbol,
3396  exp->elts[pc + 1].block);
3397  exp = *expp;
3398  }
3399  break;
3400 
3401  case OP_FUNCALL:
3402  {
3403  if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
3404  && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
3405  {
3406  struct ada_symbol_info *candidates;
3407  int n_candidates;
3408 
3409  n_candidates =
3411  (exp->elts[pc + 5].symbol),
3412  exp->elts[pc + 4].block, VAR_DOMAIN,
3413  &candidates);
3414  if (n_candidates == 1)
3415  i = 0;
3416  else
3417  {
3419  (candidates, n_candidates,
3420  argvec, nargs,
3421  SYMBOL_LINKAGE_NAME (exp->elts[pc + 5].symbol),
3422  context_type);
3423  if (i < 0)
3424  error (_("Could not find a match for %s"),
3425  SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
3426  }
3427 
3428  exp->elts[pc + 4].block = candidates[i].block;
3429  exp->elts[pc + 5].symbol = candidates[i].sym;
3430  if (innermost_block == NULL
3431  || contained_in (candidates[i].block, innermost_block))
3432  innermost_block = candidates[i].block;
3433  }
3434  }
3435  break;
3436  case BINOP_ADD:
3437  case BINOP_SUB:
3438  case BINOP_MUL:
3439  case BINOP_DIV:
3440  case BINOP_REM:
3441  case BINOP_MOD:
3442  case BINOP_CONCAT:
3443  case BINOP_BITWISE_AND:
3444  case BINOP_BITWISE_IOR:
3445  case BINOP_BITWISE_XOR:
3446  case BINOP_EQUAL:
3447  case BINOP_NOTEQUAL:
3448  case BINOP_LESS:
3449  case BINOP_GTR:
3450  case BINOP_LEQ:
3451  case BINOP_GEQ:
3452  case BINOP_EXP:
3453  case UNOP_NEG:
3454  case UNOP_PLUS:
3455  case UNOP_LOGICAL_NOT:
3456  case UNOP_ABS:
3457  if (possible_user_operator_p (op, argvec))
3458  {
3459  struct ada_symbol_info *candidates;
3460  int n_candidates;
3461 
3462  n_candidates =
3464  (struct block *) NULL, VAR_DOMAIN,
3465  &candidates);
3466  i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
3467  ada_decoded_op_name (op), NULL);
3468  if (i < 0)
3469  break;
3470 
3471  replace_operator_with_call (expp, pc, nargs, 1,
3472  candidates[i].sym, candidates[i].block);
3473  exp = *expp;
3474  }
3475  break;
3476 
3477  case OP_TYPE:
3478  case OP_REGISTER:
3479  return NULL;
3480  }
3481 
3482  *pos = pc;
3483  return evaluate_subexp_type (exp, pos);
3484 }
3485 
3486 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
3487  MAY_DEREF is non-zero, the formal may be a pointer and the actual
3488  a non-pointer. */
3489 /* The term "match" here is rather loose. The match is heuristic and
3490  liberal. */
3491 
3492 static int
3493 ada_type_match (struct type *ftype, struct type *atype, int may_deref)
3494 {
3495  ftype = ada_check_typedef (ftype);
3496  atype = ada_check_typedef (atype);
3497 
3498  if (TYPE_CODE (ftype) == TYPE_CODE_REF)
3499  ftype = TYPE_TARGET_TYPE (ftype);
3500  if (TYPE_CODE (atype) == TYPE_CODE_REF)
3501  atype = TYPE_TARGET_TYPE (atype);
3502 
3503  switch (TYPE_CODE (ftype))
3504  {
3505  default:
3506  return TYPE_CODE (ftype) == TYPE_CODE (atype);
3507  case TYPE_CODE_PTR:
3508  if (TYPE_CODE (atype) == TYPE_CODE_PTR)
3509  return ada_type_match (TYPE_TARGET_TYPE (ftype),
3510  TYPE_TARGET_TYPE (atype), 0);
3511  else
3512  return (may_deref
3513  && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
3514  case TYPE_CODE_INT:
3515  case TYPE_CODE_ENUM:
3516  case TYPE_CODE_RANGE:
3517  switch (TYPE_CODE (atype))
3518  {
3519  case TYPE_CODE_INT:
3520  case TYPE_CODE_ENUM:
3521  case TYPE_CODE_RANGE:
3522  return 1;
3523  default:
3524  return 0;
3525  }
3526 
3527  case TYPE_CODE_ARRAY:
3528  return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3529  || ada_is_array_descriptor_type (atype));
3530 
3531  case TYPE_CODE_STRUCT:
3532  if (ada_is_array_descriptor_type (ftype))
3533  return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
3534  || ada_is_array_descriptor_type (atype));
3535  else
3536  return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
3537  && !ada_is_array_descriptor_type (atype));
3538 
3539  case TYPE_CODE_UNION:
3540  case TYPE_CODE_FLT:
3541  return (TYPE_CODE (atype) == TYPE_CODE (ftype));
3542  }
3543 }
3544 
3545 /* Return non-zero if the formals of FUNC "sufficiently match" the
3546  vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
3547  may also be an enumeral, in which case it is treated as a 0-
3548  argument function. */
3549 
3550 static int
3551 ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
3552 {
3553  int i;
3554  struct type *func_type = SYMBOL_TYPE (func);
3555 
3556  if (SYMBOL_CLASS (func) == LOC_CONST
3557  && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
3558  return (n_actuals == 0);
3559  else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
3560  return 0;
3561 
3562  if (TYPE_NFIELDS (func_type) != n_actuals)
3563  return 0;
3564 
3565  for (i = 0; i < n_actuals; i += 1)
3566  {
3567  if (actuals[i] == NULL)
3568  return 0;
3569  else
3570  {
3571  struct type *ftype = ada_check_typedef (TYPE_FIELD_TYPE (func_type,
3572  i));
3573  struct type *atype = ada_check_typedef (value_type (actuals[i]));
3574 
3575  if (!ada_type_match (ftype, atype, 1))
3576  return 0;
3577  }
3578  }
3579  return 1;
3580 }
3581 
3582 /* False iff function type FUNC_TYPE definitely does not produce a value
3583  compatible with type CONTEXT_TYPE. Conservatively returns 1 if
3584  FUNC_TYPE is not a valid function type with a non-null return type
3585  or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
3586 
3587 static int
3588 return_match (struct type *func_type, struct type *context_type)
3589 {
3590  struct type *return_type;
3591 
3592  if (func_type == NULL)
3593  return 1;
3594 
3595  if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
3596  return_type = get_base_type (TYPE_TARGET_TYPE (func_type));
3597  else
3598  return_type = get_base_type (func_type);
3599  if (return_type == NULL)
3600  return 1;
3601 
3602  context_type = get_base_type (context_type);
3603 
3604  if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
3605  return context_type == NULL || return_type == context_type;
3606  else if (context_type == NULL)
3607  return TYPE_CODE (return_type) != TYPE_CODE_VOID;
3608  else
3609  return TYPE_CODE (return_type) == TYPE_CODE (context_type);
3610 }
3611 
3612 
3613 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
3614  function (if any) that matches the types of the NARGS arguments in
3615  ARGS. If CONTEXT_TYPE is non-null and there is at least one match
3616  that returns that type, then eliminate matches that don't. If
3617  CONTEXT_TYPE is void and there is at least one match that does not
3618  return void, eliminate all matches that do.
3619 
3620  Asks the user if there is more than one match remaining. Returns -1
3621  if there is no such symbol or none is selected. NAME is used
3622  solely for messages. May re-arrange and modify SYMS in
3623  the process; the index returned is for the modified vector. */
3624 
3625 static int
3627  int nsyms, struct value **args, int nargs,
3628  const char *name, struct type *context_type)
3629 {
3630  int fallback;
3631  int k;
3632  int m; /* Number of hits */
3633 
3634  m = 0;
3635  /* In the first pass of the loop, we only accept functions matching
3636  context_type. If none are found, we add a second pass of the loop
3637  where every function is accepted. */
3638  for (fallback = 0; m == 0 && fallback < 2; fallback++)
3639  {
3640  for (k = 0; k < nsyms; k += 1)
3641  {
3642  struct type *type = ada_check_typedef (SYMBOL_TYPE (syms[k].sym));
3643 
3644  if (ada_args_match (syms[k].sym, args, nargs)
3645  && (fallback || return_match (type, context_type)))
3646  {
3647  syms[m] = syms[k];
3648  m += 1;
3649  }
3650  }
3651  }
3652 
3653  if (m == 0)
3654  return -1;
3655  else if (m > 1)
3656  {
3657  printf_filtered (_("Multiple matches for %s\n"), name);
3658  user_select_syms (syms, m, 1);
3659  return 0;
3660  }
3661  return 0;
3662 }
3663 
3664 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3665  in a listing of choices during disambiguation (see sort_choices, below).
3666  The idea is that overloadings of a subprogram name from the
3667  same package should sort in their source order. We settle for ordering
3668  such symbols by their trailing number (__N or $N). */
3669 
3670 static int
3671 encoded_ordered_before (const char *N0, const char *N1)
3672 {
3673  if (N1 == NULL)
3674  return 0;
3675  else if (N0 == NULL)
3676  return 1;
3677  else
3678  {
3679  int k0, k1;
3680 
3681  for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
3682  ;
3683  for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
3684  ;
3685  if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
3686  && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3687  {
3688  int n0, n1;
3689 
3690  n0 = k0;
3691  while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3692  n0 -= 1;
3693  n1 = k1;
3694  while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3695  n1 -= 1;
3696  if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3697  return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3698  }
3699  return (strcmp (N0, N1) < 0);
3700  }
3701 }
3702 
3703 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3704  encoded names. */
3705 
3706 static void
3707 sort_choices (struct ada_symbol_info syms[], int nsyms)
3708 {
3709  int i;
3710 
3711  for (i = 1; i < nsyms; i += 1)
3712  {
3713  struct ada_symbol_info sym = syms[i];
3714  int j;
3715 
3716  for (j = i - 1; j >= 0; j -= 1)
3717  {
3718  if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3719  SYMBOL_LINKAGE_NAME (sym.sym)))
3720  break;
3721  syms[j + 1] = syms[j];
3722  }
3723  syms[j + 1] = sym;
3724  }
3725 }
3726 
3727 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3728  by asking the user (if necessary), returning the number selected,
3729  and setting the first elements of SYMS items. Error if no symbols
3730  selected. */
3731 
3732 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3733  to be re-integrated one of these days. */
3734 
3735 int
3736 user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
3737 {
3738  int i;
3739  int *chosen = (int *) alloca (sizeof (int) * nsyms);
3740  int n_chosen;
3741  int first_choice = (max_results == 1) ? 1 : 2;
3742  const char *select_mode = multiple_symbols_select_mode ();
3743 
3744  if (max_results < 1)
3745  error (_("Request to select 0 symbols!"));
3746  if (nsyms <= 1)
3747  return nsyms;
3748 
3749  if (select_mode == multiple_symbols_cancel)
3750  error (_("\
3751 canceled because the command is ambiguous\n\
3752 See set/show multiple-symbol."));
3753 
3754  /* If select_mode is "all", then return all possible symbols.
3755  Only do that if more than one symbol can be selected, of course.
3756  Otherwise, display the menu as usual. */
3757  if (select_mode == multiple_symbols_all && max_results > 1)
3758  return nsyms;
3759 
3760  printf_unfiltered (_("[0] cancel\n"));
3761  if (max_results > 1)
3762  printf_unfiltered (_("[1] all\n"));
3763 
3764  sort_choices (syms, nsyms);
3765 
3766  for (i = 0; i < nsyms; i += 1)
3767  {
3768  if (syms[i].sym == NULL)
3769  continue;
3770 
3771  if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3772  {
3773  struct symtab_and_line sal =
3774  find_function_start_sal (syms[i].sym, 1);
3775 
3776  if (sal.symtab == NULL)
3777  printf_unfiltered (_("[%d] %s at <no source file available>:%d\n"),
3778  i + first_choice,
3779  SYMBOL_PRINT_NAME (syms[i].sym),
3780  sal.line);
3781  else
3782  printf_unfiltered (_("[%d] %s at %s:%d\n"), i + first_choice,
3783  SYMBOL_PRINT_NAME (syms[i].sym),
3785  sal.line);
3786  continue;
3787  }
3788  else
3789  {
3790  int is_enumeral =
3791  (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3792  && SYMBOL_TYPE (syms[i].sym) != NULL
3793  && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3794  struct symtab *symtab = NULL;
3795 
3796  if (SYMBOL_OBJFILE_OWNED (syms[i].sym))
3797  symtab = symbol_symtab (syms[i].sym);
3798 
3799  if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3800  printf_unfiltered (_("[%d] %s at %s:%d\n"),
3801  i + first_choice,
3802  SYMBOL_PRINT_NAME (syms[i].sym),
3804  SYMBOL_LINE (syms[i].sym));
3805  else if (is_enumeral
3806  && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
3807  {
3808  printf_unfiltered (("[%d] "), i + first_choice);
3809  ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3811  printf_unfiltered (_("'(%s) (enumeral)\n"),
3812  SYMBOL_PRINT_NAME (syms[i].sym));
3813  }
3814  else if (symtab != NULL)
3815  printf_unfiltered (is_enumeral
3816  ? _("[%d] %s in %s (enumeral)\n")
3817  : _("[%d] %s at %s:?\n"),
3818  i + first_choice,
3819  SYMBOL_PRINT_NAME (syms[i].sym),
3821  else
3822  printf_unfiltered (is_enumeral
3823  ? _("[%d] %s (enumeral)\n")
3824  : _("[%d] %s at ?\n"),
3825  i + first_choice,
3826  SYMBOL_PRINT_NAME (syms[i].sym));
3827  }
3828  }
3829 
3830  n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
3831  "overload-choice");
3832 
3833  for (i = 0; i < n_chosen; i += 1)
3834  syms[i] = syms[chosen[i]];
3835 
3836  return n_chosen;
3837 }
3838 
3839 /* Read and validate a set of numeric choices from the user in the
3840  range 0 .. N_CHOICES-1. Place the results in increasing
3841  order in CHOICES[0 .. N-1], and return N.
3842 
3843  The user types choices as a sequence of numbers on one line
3844  separated by blanks, encoding them as follows:
3845 
3846  + A choice of 0 means to cancel the selection, throwing an error.
3847  + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3848  + The user chooses k by typing k+IS_ALL_CHOICE+1.
3849 
3850  The user is not allowed to choose more than MAX_RESULTS values.
3851 
3852  ANNOTATION_SUFFIX, if present, is used to annotate the input
3853  prompts (for use with the -f switch). */
3854 
3855 int
3856 get_selections (int *choices, int n_choices, int max_results,
3857  int is_all_choice, char *annotation_suffix)
3858 {
3859  char *args;
3860  char *prompt;
3861  int n_chosen;
3862  int first_choice = is_all_choice ? 2 : 1;
3863 
3864  prompt = getenv ("PS2");
3865  if (prompt == NULL)
3866  prompt = "> ";
3867 
3868  args = command_line_input (prompt, 0, annotation_suffix);
3869 
3870  if (args == NULL)
3871  error_no_arg (_("one or more choice numbers"));
3872 
3873  n_chosen = 0;
3874 
3875  /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3876  order, as given in args. Choices are validated. */
3877  while (1)
3878  {
3879  char *args2;
3880  int choice, j;
3881 
3882  args = skip_spaces (args);
3883  if (*args == '\0' && n_chosen == 0)
3884  error_no_arg (_("one or more choice numbers"));
3885  else if (*args == '\0')
3886  break;
3887 
3888  choice = strtol (args, &args2, 10);
3889  if (args == args2 || choice < 0
3890  || choice > n_choices + first_choice - 1)
3891  error (_("Argument must be choice number"));
3892  args = args2;
3893 
3894  if (choice == 0)
3895  error (_("cancelled"));
3896 
3897  if (choice < first_choice)
3898  {
3899  n_chosen = n_choices;
3900  for (j = 0; j < n_choices; j += 1)
3901  choices[j] = j;
3902  break;
3903  }
3904  choice -= first_choice;
3905 
3906  for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
3907  {
3908  }
3909 
3910  if (j < 0 || choice != choices[j])
3911  {
3912  int k;
3913 
3914  for (k = n_chosen - 1; k > j; k -= 1)
3915  choices[k + 1] = choices[k];
3916  choices[j + 1] = choice;
3917  n_chosen += 1;
3918  }
3919  }
3920 
3921  if (n_chosen > max_results)
3922  error (_("Select no more than %d of the above"), max_results);
3923 
3924  return n_chosen;
3925 }
3926 
3927 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3928  on the function identified by SYM and BLOCK, and taking NARGS
3929  arguments. Update *EXPP as needed to hold more space. */
3930 
3931 static void
3932 replace_operator_with_call (struct expression **expp, int pc, int nargs,
3933  int oplen, struct symbol *sym,
3934  const struct block *block)
3935 {
3936  /* A new expression, with 6 more elements (3 for funcall, 4 for function
3937  symbol, -oplen for operator being replaced). */
3938  struct expression *newexp = (struct expression *)
3939  xzalloc (sizeof (struct expression)
3940  + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
3941  struct expression *exp = *expp;
3942 
3943  newexp->nelts = exp->nelts + 7 - oplen;
3944  newexp->language_defn = exp->language_defn;
3945  newexp->gdbarch = exp->gdbarch;
3946  memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
3947  memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
3948  EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
3949 
3950  newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3951  newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3952 
3953  newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3954  newexp->elts[pc + 4].block = block;
3955  newexp->elts[pc + 5].symbol = sym;
3956 
3957  *expp = newexp;
3958  xfree (exp);
3959 }
3960 
3961 /* Type-class predicates */
3962 
3963 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3964  or FLOAT). */
3965 
3966 static int
3968 {
3969  if (type == NULL)
3970  return 0;
3971  else
3972  {
3973  switch (TYPE_CODE (type))
3974  {
3975  case TYPE_CODE_INT:
3976  case TYPE_CODE_FLT:
3977  return 1;
3978  case TYPE_CODE_RANGE:
3979  return (type == TYPE_TARGET_TYPE (type)
3980  || numeric_type_p (TYPE_TARGET_TYPE (type)));
3981  default:
3982  return 0;
3983  }
3984  }
3985 }
3986 
3987 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3988 
3989 static int
3991 {
3992  if (type == NULL)
3993  return 0;
3994  else
3995  {
3996  switch (TYPE_CODE (type))
3997  {
3998  case TYPE_CODE_INT:
3999  return 1;
4000  case TYPE_CODE_RANGE:
4001  return (type == TYPE_TARGET_TYPE (type)
4002  || integer_type_p (TYPE_TARGET_TYPE (type)));
4003  default:
4004  return 0;
4005  }
4006  }
4007 }
4008 
4009 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
4010 
4011 static int
4013 {
4014  if (type == NULL)
4015  return 0;
4016  else
4017  {
4018  switch (TYPE_CODE (type))
4019  {
4020  case TYPE_CODE_INT:
4021  case TYPE_CODE_RANGE:
4022  case TYPE_CODE_ENUM:
4023  case TYPE_CODE_FLT:
4024  return 1;
4025  default:
4026  return 0;
4027  }
4028  }
4029 }
4030 
4031 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
4032 
4033 static int
4035 {
4036  if (type == NULL)
4037  return 0;
4038  else
4039  {
4040  switch (TYPE_CODE (type))
4041  {
4042  case TYPE_CODE_INT:
4043  case TYPE_CODE_RANGE:
4044  case TYPE_CODE_ENUM:
4045  case TYPE_CODE_BOOL:
4046  return 1;
4047  default:
4048  return 0;
4049  }
4050  }
4051 }
4052 
4053 /* Returns non-zero if OP with operands in the vector ARGS could be
4054  a user-defined function. Errs on the side of pre-defined operators
4055  (i.e., result 0). */
4056 
4057 static int
4058 possible_user_operator_p (enum exp_opcode op, struct value *args[])
4059 {
4060  struct type *type0 =
4061  (args[0] == NULL) ? NULL : ada_check_typedef (value_type (args[0]));
4062  struct type *type1 =
4063  (args[1] == NULL) ? NULL : ada_check_typedef (value_type (args[1]));
4064 
4065  if (type0 == NULL)
4066  return 0;
4067 
4068  switch (op)
4069  {
4070  default:
4071  return 0;
4072 
4073  case BINOP_ADD:
4074  case BINOP_SUB:
4075  case BINOP_MUL:
4076  case BINOP_DIV:
4077  return (!(numeric_type_p (type0) && numeric_type_p (type1)));
4078 
4079  case BINOP_REM:
4080  case BINOP_MOD:
4081  case BINOP_BITWISE_AND:
4082  case BINOP_BITWISE_IOR:
4083  case BINOP_BITWISE_XOR:
4084  return (!(integer_type_p (type0) && integer_type_p (type1)));
4085 
4086  case BINOP_EQUAL:
4087  case BINOP_NOTEQUAL:
4088  case BINOP_LESS:
4089  case BINOP_GTR:
4090  case BINOP_LEQ:
4091  case BINOP_GEQ:
4092  return (!(scalar_type_p (type0) && scalar_type_p (type1)));
4093 
4094  case BINOP_CONCAT:
4095  return !ada_is_array_type (type0) || !ada_is_array_type (type1);
4096 
4097  case BINOP_EXP:
4098  return (!(numeric_type_p (type0) && integer_type_p (type1)));
4099 
4100  case UNOP_NEG:
4101  case UNOP_PLUS:
4102  case UNOP_LOGICAL_NOT:
4103  case UNOP_ABS:
4104  return (!numeric_type_p (type0));
4105 
4106  }
4107 }
4108 
4109  /* Renaming */
4110 
4111 /* NOTES:
4112 
4113  1. In the following, we assume that a renaming type's name may
4114  have an ___XD suffix. It would be nice if this went away at some
4115  point.
4116  2. We handle both the (old) purely type-based representation of
4117  renamings and the (new) variable-based encoding. At some point,
4118  it is devoutly to be hoped that the former goes away
4119  (FIXME: hilfinger-2007-07-09).
4120  3. Subprogram renamings are not implemented, although the XRS
4121  suffix is recognized (FIXME: hilfinger-2007-07-09). */
4122 
4123 /* If SYM encodes a renaming,
4124 
4125  <renaming> renames <renamed entity>,
4126 
4127  sets *LEN to the length of the renamed entity's name,
4128  *RENAMED_ENTITY to that name (not null-terminated), and *RENAMING_EXPR to
4129  the string describing the subcomponent selected from the renamed
4130  entity. Returns ADA_NOT_RENAMING if SYM does not encode a renaming
4131  (in which case, the values of *RENAMED_ENTITY, *LEN, and *RENAMING_EXPR
4132  are undefined). Otherwise, returns a value indicating the category
4133  of entity renamed: an object (ADA_OBJECT_RENAMING), exception
4134  (ADA_EXCEPTION_RENAMING), package (ADA_PACKAGE_RENAMING), or
4135  subprogram (ADA_SUBPROGRAM_RENAMING). Does no allocation; the
4136  strings returned in *RENAMED_ENTITY and *RENAMING_EXPR should not be
4137  deallocated. The values of RENAMED_ENTITY, LEN, or RENAMING_EXPR
4138  may be NULL, in which case they are not assigned.
4139 
4140  [Currently, however, GCC does not generate subprogram renamings.] */
4141 
4144  const char **renamed_entity, int *len,
4145  const char **renaming_expr)
4146 {
4147  enum ada_renaming_category kind;
4148  const char *info;
4149  const char *suffix;
4150 
4151  if (sym == NULL)
4152  return ADA_NOT_RENAMING;
4153  switch (SYMBOL_CLASS (sym))
4154  {
4155  default:
4156  return ADA_NOT_RENAMING;
4157  case LOC_TYPEDEF:
4158  return parse_old_style_renaming (SYMBOL_TYPE (sym),
4159  renamed_entity, len, renaming_expr);
4160  case LOC_LOCAL:
4161  case LOC_STATIC:
4162  case LOC_COMPUTED:
4163  case LOC_OPTIMIZED_OUT:
4164  info = strstr (SYMBOL_LINKAGE_NAME (sym), "___XR");
4165  if (info == NULL)
4166  return ADA_NOT_RENAMING;
4167  switch (info[5])
4168  {
4169  case '_':
4170  kind = ADA_OBJECT_RENAMING;
4171  info += 6;
4172  break;
4173  case 'E':
4174  kind = ADA_EXCEPTION_RENAMING;
4175  info += 7;
4176  break;
4177  case 'P':
4178  kind = ADA_PACKAGE_RENAMING;
4179  info += 7;
4180  break;
4181  case 'S':
4182  kind = ADA_SUBPROGRAM_RENAMING;
4183  info += 7;
4184  break;
4185  default:
4186  return ADA_NOT_RENAMING;
4187  }
4188  }
4189 
4190  if (renamed_entity != NULL)
4191  *renamed_entity = info;
4192  suffix = strstr (info, "___XE");
4193  if (suffix == NULL || suffix == info)
4194  return ADA_NOT_RENAMING;
4195  if (len != NULL)
4196  *len = strlen (info) - strlen (suffix);
4197  suffix += 5;
4198  if (renaming_expr != NULL)
4199  *renaming_expr = suffix;
4200  return kind;
4201 }
4202 
4203 /* Assuming TYPE encodes a renaming according to the old encoding in
4204  exp_dbug.ads, returns details of that renaming in *RENAMED_ENTITY,
4205  *LEN, and *RENAMING_EXPR, as for ada_parse_renaming, above. Returns
4206  ADA_NOT_RENAMING otherwise. */
4207 static enum ada_renaming_category
4209  const char **renamed_entity, int *len,
4210  const char **renaming_expr)
4211 {
4212  enum ada_renaming_category kind;
4213  const char *name;
4214  const char *info;
4215  const char *suffix;
4216 
4217  if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
4218  || TYPE_NFIELDS (type) != 1)
4219  return ADA_NOT_RENAMING;
4220 
4221  name = type_name_no_tag (type);
4222  if (name == NULL)
4223  return ADA_NOT_RENAMING;
4224 
4225  name = strstr (name, "___XR");
4226  if (name == NULL)
4227  return ADA_NOT_RENAMING;
4228  switch (name[5])
4229  {
4230  case '\0':
4231  case '_':
4232  kind = ADA_OBJECT_RENAMING;
4233  break;
4234  case 'E':
4235  kind = ADA_EXCEPTION_RENAMING;
4236  break;
4237  case 'P':
4238  kind = ADA_PACKAGE_RENAMING;
4239  break;
4240  case 'S':
4241  kind = ADA_SUBPROGRAM_RENAMING;
4242  break;
4243  default:
4244  return ADA_NOT_RENAMING;
4245  }
4246 
4247  info = TYPE_FIELD_NAME (type, 0);
4248  if (info == NULL)
4249  return ADA_NOT_RENAMING;
4250  if (renamed_entity != NULL)
4251  *renamed_entity = info;
4252  suffix = strstr (info, "___XE");
4253  if (renaming_expr != NULL)
4254  *renaming_expr = suffix + 5;
4255  if (suffix == NULL || suffix == info)
4256  return ADA_NOT_RENAMING;
4257  if (len != NULL)
4258  *len = suffix - info;
4259  return kind;
4260 }
4261 
4262 /* Compute the value of the given RENAMING_SYM, which is expected to
4263  be a symbol encoding a renaming expression. BLOCK is the block
4264  used to evaluate the renaming. */
4265 
4266 static struct value *
4267 ada_read_renaming_var_value (struct symbol *renaming_sym,
4268  const struct block *block)
4269 {
4270  const char *sym_name;
4271  struct expression *expr;
4272  struct value *value;
4273  struct cleanup *old_chain = NULL;
4274 
4275  sym_name = SYMBOL_LINKAGE_NAME (renaming_sym);
4276  expr = parse_exp_1 (&sym_name, 0, block, 0);
4277  old_chain = make_cleanup (free_current_contents, &expr);
4278  value = evaluate_expression (expr);
4279 
4280  do_cleanups (old_chain);
4281  return value;
4282 }
4283 
4284 
4285  /* Evaluation: Function Calls */
4286 
4287 /* Return an lvalue containing the value VAL. This is the identity on
4288  lvalues, and otherwise has the side-effect of allocating memory
4289  in the inferior where a copy of the value contents is copied. */
4290 
4291 static struct value *
4292 ensure_lval (struct value *val)
4293 {
4294  if (VALUE_LVAL (val) == not_lval
4295  || VALUE_LVAL (val) == lval_internalvar)
4296  {
4297  int len = TYPE_LENGTH (ada_check_typedef (value_type (val)));
4298  const CORE_ADDR addr =
4300 
4301  set_value_address (val, addr);
4302  VALUE_LVAL (val) = lval_memory;
4303  write_memory (addr, value_contents (val), len);
4304  }
4305 
4306  return val;
4307 }
4308 
4309 /* Return the value ACTUAL, converted to be an appropriate value for a
4310  formal of type FORMAL_TYPE. Use *SP as a stack pointer for
4311  allocating any necessary descriptors (fat pointers), or copies of
4312  values not residing in memory, updating it as needed. */
4313 
4314 struct value *
4315 ada_convert_actual (struct value *actual, struct type *formal_type0)
4316 {
4317  struct type *actual_type = ada_check_typedef (value_type (actual));
4318  struct type *formal_type = ada_check_typedef (formal_type0);
4319  struct type *formal_target =
4320  TYPE_CODE (formal_type) == TYPE_CODE_PTR
4321  ? ada_check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
4322  struct type *actual_target =
4323  TYPE_CODE (actual_type) == TYPE_CODE_PTR
4324  ? ada_check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
4325 
4326  if (ada_is_array_descriptor_type (formal_target)
4327  && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
4328  return make_array_descriptor (formal_type, actual);
4329  else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR
4330  || TYPE_CODE (formal_type) == TYPE_CODE_REF)
4331  {
4332  struct value *result;
4333 
4334  if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4335  && ada_is_array_descriptor_type (actual_target))
4336  result = desc_data (actual);
4337  else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4338  {
4339  if (VALUE_LVAL (actual) != lval_memory)
4340  {
4341  struct value *val;
4342 
4343  actual_type = ada_check_typedef (value_type (actual));
4344  val = allocate_value (actual_type);
4345  memcpy ((char *) value_contents_raw (val),
4346  (char *) value_contents (actual),
4347  TYPE_LENGTH (actual_type));
4348  actual = ensure_lval (val);
4349  }
4350  result = value_addr (actual);
4351  }
4352  else
4353  return actual;
4354  return value_cast_pointers (formal_type, result, 0);
4355  }
4356  else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
4357  return ada_value_ind (actual);
4358  else if (ada_is_aligner_type (formal_type))
4359  {
4360  /* We need to turn this parameter into an aligner type
4361  as well. */
4362  struct value *aligner = allocate_value (formal_type);
4363  struct value *component = ada_value_struct_elt (aligner, "F", 0);
4364 
4365  value_assign_to_component (aligner, component, actual);
4366  return aligner;
4367  }
4368 
4369  return actual;
4370 }
4371 
4372 /* Convert VALUE (which must be an address) to a CORE_ADDR that is a pointer of
4373  type TYPE. This is usually an inefficient no-op except on some targets
4374  (such as AVR) where the representation of a pointer and an address
4375  differs. */
4376 
4377 static CORE_ADDR
4378 value_pointer (struct value *value, struct type *type)
4379 {
4380  struct gdbarch *gdbarch = get_type_arch (type);
4381  unsigned len = TYPE_LENGTH (type);
4382  gdb_byte *buf = alloca (len);
4383  CORE_ADDR addr;
4384 
4385  addr = value_address (value);
4386  gdbarch_address_to_pointer (gdbarch, type, buf, addr);
4387  addr = extract_unsigned_integer (buf, len, gdbarch_byte_order (gdbarch));
4388  return addr;
4389 }
4390 
4391 
4392 /* Push a descriptor of type TYPE for array value ARR on the stack at
4393  *SP, updating *SP to reflect the new descriptor. Return either
4394  an lvalue representing the new descriptor, or (if TYPE is a pointer-
4395  to-descriptor type rather than a descriptor type), a struct value *
4396  representing a pointer to this descriptor. */
4397 
4398 static struct value *
4399 make_array_descriptor (struct type *type, struct value *arr)
4400 {
4401  struct type *bounds_type = desc_bounds_type (type);
4402  struct type *desc_type = desc_base_type (type);
4403  struct value *descriptor = allocate_value (desc_type);
4404  struct value *bounds = allocate_value (bounds_type);
4405  int i;
4406 
4407  for (i = ada_array_arity (ada_check_typedef (value_type (arr)));
4408  i > 0; i -= 1)
4409  {
4410  modify_field (value_type (bounds), value_contents_writeable (bounds),
4411  ada_array_bound (arr, i, 0),
4412  desc_bound_bitpos (bounds_type, i, 0),
4413  desc_bound_bitsize (bounds_type, i, 0));
4414  modify_field (value_type (bounds), value_contents_writeable (bounds),
4415  ada_array_bound (arr, i, 1),
4416  desc_bound_bitpos (bounds_type, i, 1),
4417  desc_bound_bitsize (bounds_type, i, 1));
4418  }
4419 
4420  bounds = ensure_lval (bounds);
4421 
4422  modify_field (value_type (descriptor),
4423  value_contents_writeable (descriptor),
4424  value_pointer (ensure_lval (arr),
4425  TYPE_FIELD_TYPE (desc_type, 0)),
4426  fat_pntr_data_bitpos (desc_type),
4427  fat_pntr_data_bitsize (desc_type));
4428 
4429  modify_field (value_type (descriptor),
4430  value_contents_writeable (descriptor),
4431  value_pointer (bounds,
4432  TYPE_FIELD_TYPE (desc_type, 1)),
4433  fat_pntr_bounds_bitpos (desc_type),
4434  fat_pntr_bounds_bitsize (desc_type));
4435 
4436  descriptor = ensure_lval (descriptor);
4437 
4438  if (TYPE_CODE (type) == TYPE_CODE_PTR)
4439  return value_addr (descriptor);
4440  else
4441  return descriptor;
4442 }
4443 
4444  /* Symbol Cache Module */
4445 
4446 /* Performance measurements made as of 2010-01-15 indicate that
4447  this cache does bring some noticeable improvements. Depending
4448  on the type of entity being printed, the cache can make it as much
4449  as an order of magnitude faster than without it.
4450 
4451  The descriptive type DWARF extension has significantly reduced
4452  the need for this cache, at least when DWARF is being used. However,
4453  even in this case, some expensive name-based symbol searches are still
4454  sometimes necessary - to find an XVZ variable, mostly. */
4455 
4456 /* Initialize the contents of SYM_CACHE. */
4457 
4458 static void
4460 {
4461  obstack_init (&sym_cache->cache_space);
4462  memset (sym_cache->root, '\000', sizeof (sym_cache->root));
4463 }
4464 
4465 /* Free the memory used by SYM_CACHE. */
4466 
4467 static void
4469 {
4470  obstack_free (&sym_cache->cache_space, NULL);
4471  xfree (sym_cache);
4472 }
4473 
4474 /* Return the symbol cache associated to the given program space PSPACE.
4475  If not allocated for this PSPACE yet, allocate and initialize one. */
4476 
4477 static struct ada_symbol_cache *
4479 {
4480  struct ada_pspace_data *pspace_data = get_ada_pspace_data (pspace);
4481 
4482  if (pspace_data->sym_cache == NULL)
4483  {
4484  pspace_data->sym_cache = XCNEW (struct ada_symbol_cache);
4485  ada_init_symbol_cache (pspace_data->sym_cache);
4486  }
4487 
4488  return pspace_data->sym_cache;
4489 }
4490 
4491 /* Clear all entries from the symbol cache. */
4492 
4493 static void
4495 {
4496  struct ada_symbol_cache *sym_cache
4498 
4499  obstack_free (&sym_cache->cache_space, NULL);
4500  ada_init_symbol_cache (sym_cache);
4501 }
4502 
4503 /* Search our cache for an entry matching NAME and DOMAIN.
4504  Return it if found, or NULL otherwise. */
4505 
4506 static struct cache_entry **
4508 {
4509  struct ada_symbol_cache *sym_cache
4511  int h = msymbol_hash (name) % HASH_SIZE;
4512  struct cache_entry **e;
4513 
4514  for (e = &sym_cache->root[h]; *e != NULL; e = &(*e)->next)
4515  {
4516  if (domain == (*e)->domain && strcmp (name, (*e)->name) == 0)
4517  return e;
4518  }
4519  return NULL;
4520 }
4521 
4522 /* Search the symbol cache for an entry matching NAME and DOMAIN.
4523  Return 1 if found, 0 otherwise.
4524 
4525  If an entry was found and SYM is not NULL, set *SYM to the entry's
4526  SYM. Same principle for BLOCK if not NULL. */
4527 
4528 static int
4530  struct symbol **sym, const struct block **block)
4531 {
4532  struct cache_entry **e = find_entry (name, domain);
4533 
4534  if (e == NULL)
4535  return 0;
4536  if (sym != NULL)
4537  *sym = (*e)->sym;
4538  if (block != NULL)
4539  *block = (*e)->block;
4540  return 1;
4541 }
4542 
4543 /* Assuming that (SYM, BLOCK) is the result of the lookup of NAME
4544  in domain DOMAIN, save this result in our symbol cache. */
4545 
4546 static void
4548  const struct block *block)
4549 {
4550  struct ada_symbol_cache *sym_cache
4552  int h;
4553  char *copy;
4554  struct cache_entry *e;
4555 
4556  /* Symbols for builtin types don't have a block.
4557  For now don't cache such symbols. */
4558  if (sym != NULL && !SYMBOL_OBJFILE_OWNED (sym))
4559  return;
4560 
4561  /* If the symbol is a local symbol, then do not cache it, as a search
4562  for that symbol depends on the context. To determine whether
4563  the symbol is local or not, we check the block where we found it
4564  against the global and static blocks of its associated symtab. */
4565  if (sym
4567  GLOBAL_BLOCK) != block
4569  STATIC_BLOCK) != block)
4570  return;
4571 
4572  h = msymbol_hash (name) % HASH_SIZE;
4573  e = (struct cache_entry *) obstack_alloc (&sym_cache->cache_space,
4574  sizeof (*e));
4575  e->next = sym_cache->root[h];
4576  sym_cache->root[h] = e;
4577  e->name = copy = obstack_alloc (&sym_cache->cache_space, strlen (name) + 1);
4578  strcpy (copy, name);
4579  e->sym = sym;
4580  e->domain = domain;
4581  e->block = block;
4582 }
4583 
4584  /* Symbol Lookup */
4585 
4586 /* Return nonzero if wild matching should be used when searching for
4587  all symbols matching LOOKUP_NAME.
4588 
4589  LOOKUP_NAME is expected to be a symbol name after transformation
4590  for Ada lookups (see ada_name_for_lookup). */
4591 
4592 static int
4593 should_use_wild_match (const char *lookup_name)
4594 {
4595  return (strstr (lookup_name, "__") == NULL);
4596 }
4597 
4598 /* Return the result of a standard (literal, C-like) lookup of NAME in
4599  given DOMAIN, visible from lexical block BLOCK. */
4600 
4601 static struct symbol *
4602 standard_lookup (const char *name, const struct block *block,
4604 {
4605  /* Initialize it just to avoid a GCC false warning. */
4606  struct symbol *sym = NULL;
4607 
4608  if (lookup_cached_symbol (name, domain, &sym, NULL))
4609  return sym;
4610  sym = lookup_symbol_in_language (name, block, domain, language_c, 0);
4611  cache_symbol (name, domain, sym, block_found);
4612  return sym;
4613 }
4614 
4615 
4616 /* Non-zero iff there is at least one non-function/non-enumeral symbol
4617  in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
4618  since they contend in overloading in the same way. */
4619 static int
4620 is_nonfunction (struct ada_symbol_info syms[], int n)
4621 {
4622  int i;
4623 
4624  for (i = 0; i < n; i += 1)
4625  if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
4626  && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
4627  || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
4628  return 1;
4629 
4630  return 0;
4631 }
4632 
4633 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4634  struct types. Otherwise, they may not. */
4635 
4636 static int
4637 equiv_types (struct type *type0, struct type *type1)
4638 {
4639  if (type0 == type1)
4640  return 1;
4641  if (type0 == NULL || type1 == NULL
4642  || TYPE_CODE (type0) != TYPE_CODE (type1))
4643  return 0;
4644  if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
4645  || TYPE_CODE (type0) == TYPE_CODE_ENUM)
4646  && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4647  && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
4648  return 1;
4649 
4650  return 0;
4651 }
4652 
4653 /* True iff SYM0 represents the same entity as SYM1, or one that is
4654  no more defined than that of SYM1. */
4655 
4656 static int
4657 lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
4658 {
4659  if (sym0 == sym1)
4660  return 1;
4661  if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
4662  || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
4663  return 0;
4664 
4665  switch (SYMBOL_CLASS (sym0))
4666  {
4667  case LOC_UNDEF:
4668  return 1;
4669  case LOC_TYPEDEF:
4670  {
4671  struct type *type0 = SYMBOL_TYPE (sym0);
4672  struct type *type1 = SYMBOL_TYPE (sym1);
4673  const char *name0 = SYMBOL_LINKAGE_NAME (sym0);
4674  const char *name1 = SYMBOL_LINKAGE_NAME (sym1);
4675  int len0 = strlen (name0);
4676 
4677  return
4678  TYPE_CODE (type0) == TYPE_CODE (type1)
4679  && (equiv_types (type0, type1)
4680  || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
4681  && startswith (name1 + len0, "___XV")));
4682  }
4683  case LOC_CONST:
4684  return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4685  && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
4686  default:
4687  return 0;
4688  }
4689 }
4690 
4691 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
4692  records in OBSTACKP. Do nothing if SYM is a duplicate. */
4693 
4694 static void
4695 add_defn_to_vec (struct obstack *obstackp,
4696  struct symbol *sym,
4697  const struct block *block)
4698 {
4699  int i;
4700  struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
4701 
4702  /* Do not try to complete stub types, as the debugger is probably
4703  already scanning all symbols matching a certain name at the
4704  time when this function is called. Trying to replace the stub
4705  type by its associated full type will cause us to restart a scan
4706  which may lead to an infinite recursion. Instead, the client
4707  collecting the matching symbols will end up collecting several
4708  matches, with at least one of them complete. It can then filter
4709  out the stub ones if needed. */
4710 
4711  for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
4712  {
4713  if (lesseq_defined_than (sym, prevDefns[i].sym))
4714  return;
4715  else if (lesseq_defined_than (prevDefns[i].sym, sym))
4716  {
4717  prevDefns[i].sym = sym;
4718  prevDefns[i].block = block;
4719  return;
4720  }
4721  }
4722 
4723  {
4724  struct ada_symbol_info info;
4725 
4726  info.sym = sym;
4727  info.block = block;
4728  obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
4729  }
4730 }
4731 
4732 /* Number of ada_symbol_info structures currently collected in
4733  current vector in *OBSTACKP. */
4734 
4735 static int
4736 num_defns_collected (struct obstack *obstackp)
4737 {
4738  return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
4739 }
4740 
4741 /* Vector of ada_symbol_info structures currently collected in current
4742  vector in *OBSTACKP. If FINISH, close off the vector and return
4743  its final address. */
4744 
4745 static struct ada_symbol_info *
4746 defns_collected (struct obstack *obstackp, int finish)
4747 {
4748  if (finish)
4749  return obstack_finish (obstackp);
4750  else
4751  return (struct ada_symbol_info *) obstack_base (obstackp);
4752 }
4753 
4754 /* Return a bound minimal symbol matching NAME according to Ada
4755  decoding rules. Returns an invalid symbol if there is no such
4756  minimal symbol. Names prefixed with "standard__" are handled
4757  specially: "standard__" is first stripped off, and only static and
4758  global symbols are searched. */
4759 
4760 struct bound_minimal_symbol
4762 {
4763  struct bound_minimal_symbol result;
4764  struct objfile *objfile;
4765  struct minimal_symbol *msymbol;
4766  const int wild_match_p = should_use_wild_match (name);
4767 
4768  memset (&result, 0, sizeof (result));
4769 
4770  /* Special case: If the user specifies a symbol name inside package
4771  Standard, do a non-wild matching of the symbol name without
4772  the "standard__" prefix. This was primarily introduced in order
4773  to allow the user to specifically access the standard exceptions
4774  using, for instance, Standard.Constraint_Error when Constraint_Error
4775  is ambiguous (due to the user defining its own Constraint_Error
4776  entity inside its program). */
4777  if (startswith (name, "standard__"))
4778  name += sizeof ("standard__") - 1;
4779 
4780  ALL_MSYMBOLS (objfile, msymbol)
4781  {
4782  if (match_name (MSYMBOL_LINKAGE_NAME (msymbol), name, wild_match_p)
4783  && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4784  {
4785  result.minsym = msymbol;
4786  result.objfile = objfile;
4787  break;
4788  }
4789  }
4790 
4791  return result;
4792 }
4793 
4794 /* For all subprograms that statically enclose the subprogram of the
4795  selected frame, add symbols matching identifier NAME in DOMAIN
4796  and their blocks to the list of data in OBSTACKP, as for
4797  ada_add_block_symbols (q.v.). If WILD_MATCH_P, treat as NAME
4798  with a wildcard prefix. */
4799 
4800 static void
4801 add_symbols_from_enclosing_procs (struct obstack *obstackp,
4802  const char *name, domain_enum domain,
4803  int wild_match_p)
4804 {
4805 }
4806 
4807 /* True if TYPE is definitely an artificial type supplied to a symbol
4808  for which no debugging information was given in the symbol file. */
4809 
4810 static int
4812 {
4813  const char *name = ada_type_name (type);
4814 
4815  return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4816 }
4817 
4818 /* Return nonzero if TYPE1 and TYPE2 are two enumeration types
4819  that are deemed "identical" for practical purposes.
4820 
4821  This function assumes that TYPE1 and TYPE2 are both TYPE_CODE_ENUM
4822  types and that their number of enumerals is identical (in other
4823  words, TYPE_NFIELDS (type1) == TYPE_NFIELDS (type2)). */
4824 
4825 static int
4826 ada_identical_enum_types_p (struct type *type1, struct type *type2)
4827 {
4828  int i;
4829 
4830  /* The heuristic we use here is fairly conservative. We consider
4831  that 2 enumerate types are identical if they have the same
4832  number of enumerals and that all enumerals have the same
4833  underlying value and name. */
4834 
4835  /* All enums in the type should have an identical underlying value. */
4836  for (i = 0; i < TYPE_NFIELDS (type1); i++)
4837  if (TYPE_FIELD_ENUMVAL (type1, i) != TYPE_FIELD_ENUMVAL (type2, i))
4838  return 0;
4839 
4840  /* All enumerals should also have the same name (modulo any numerical
4841  suffix). */
4842  for (i = 0; i < TYPE_NFIELDS (type1); i++)
4843  {
4844  const char *name_1 = TYPE_FIELD_NAME (type1, i);
4845  const char *name_2 = TYPE_FIELD_NAME (type2, i);
4846  int len_1 = strlen (name_1);
4847  int len_2 = strlen (name_2);
4848 
4849  ada_remove_trailing_digits (TYPE_FIELD_NAME (type1, i), &len_1);
4850  ada_remove_trailing_digits (TYPE_FIELD_NAME (type2, i), &len_2);
4851  if (len_1 != len_2
4852  || strncmp (TYPE_FIELD_NAME (type1, i),
4853  TYPE_FIELD_NAME (type2, i),
4854  len_1) != 0)
4855  return 0;
4856  }
4857 
4858  return 1;
4859 }
4860 
4861 /* Return nonzero if all the symbols in SYMS are all enumeral symbols
4862  that are deemed "identical" for practical purposes. Sometimes,
4863  enumerals are not strictly identical, but their types are so similar
4864  that they can be considered identical.
4865 
4866  For instance, consider the following code:
4867 
4868  type Color is (Black, Red, Green, Blue, White);
4869  type RGB_Color is new Color range Red .. Blue;
4870 
4871  Type RGB_Color is a subrange of an implicit type which is a copy
4872  of type Color. If we call that implicit type RGB_ColorB ("B" is
4873  for "Base Type"), then type RGB_ColorB is a copy of type Color.
4874  As a result, when an expression references any of the enumeral
4875  by name (Eg. "print green"), the expression is technically
4876  ambiguous and the user should be asked to disambiguate. But
4877  doing so would only hinder the user, since it wouldn't matter
4878  what choice he makes, the outcome would always be the same.
4879  So, for practical purposes, we consider them as the same. */
4880 
4881 static int
4883 {
4884  int i;
4885 
4886  /* Before performing a thorough comparison check of each type,
4887  we perform a series of inexpensive checks. We expect that these
4888  checks will quickly fail in the vast majority of cases, and thus
4889  help prevent the unnecessary use of a more expensive comparison.
4890  Said comparison also expects us to make some of these checks
4891  (see ada_identical_enum_types_p). */
4892 
4893  /* Quick check: All symbols should have an enum type. */
4894  for (i = 0; i < nsyms; i++)
4895  if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM)
4896  return 0;
4897 
4898  /* Quick check: They should all have the same value. */
4899  for (i = 1; i < nsyms; i++)
4900  if (SYMBOL_VALUE (syms[i].sym) != SYMBOL_VALUE (syms[0].sym))
4901  return 0;
4902 
4903  /* Quick check: They should all have the same number of enumerals. */
4904  for (i = 1; i < nsyms; i++)
4905  if (TYPE_NFIELDS (SYMBOL_TYPE (syms[i].sym))
4906  != TYPE_NFIELDS (SYMBOL_TYPE (syms[0].sym)))
4907  return 0;
4908 
4909  /* All the sanity checks passed, so we might have a set of
4910  identical enumeration types. Perform a more complete
4911  comparison of the type of each symbol. */
4912  for (i = 1; i < nsyms; i++)
4913  if (!ada_identical_enum_types_p (SYMBOL_TYPE (syms[i].sym),
4914  SYMBOL_TYPE (syms[0].sym)))
4915  return 0;
4916 
4917  return 1;
4918 }
4919 
4920 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4921  duplicate other symbols in the list (The only case I know of where
4922  this happens is when object files containing stabs-in-ecoff are
4923  linked with files containing ordinary ecoff debugging symbols (or no
4924  debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4925  Returns the number of items in the modified list. */
4926 
4927 static int
4928 remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4929 {
4930  int i, j;
4931 
4932  /* We should never be called with less than 2 symbols, as there
4933  cannot be any extra symbol in that case. But it's easy to
4934  handle, since we have nothing to do in that case. */
4935  if (nsyms < 2)
4936  return nsyms;
4937 
4938  i = 0;
4939  while (i < nsyms)
4940  {
4941  int remove_p = 0;
4942 
4943  /* If two symbols have the same name and one of them is a stub type,
4944  the get rid of the stub. */
4945 
4946  if (TYPE_STUB (SYMBOL_TYPE (syms[i].sym))
4947  && SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL)
4948  {
4949  for (j = 0; j < nsyms; j++)
4950  {
4951  if (j != i
4952  && !TYPE_STUB (SYMBOL_TYPE (syms[j].sym))
4953  && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4954  && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4955  SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0)
4956  remove_p = 1;
4957  }
4958  }
4959 
4960  /* Two symbols with the same name, same class and same address
4961  should be identical. */
4962 
4963  else if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4964  && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4965  && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4966  {
4967  for (j = 0; j < nsyms; j += 1)
4968  {
4969  if (i != j
4970  && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4971  && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
4972  SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
4973  && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4974  && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4975  == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4976  remove_p = 1;
4977  }
4978  }
4979 
4980  if (remove_p)
4981  {
4982  for (j = i + 1; j < nsyms; j += 1)
4983  syms[j - 1] = syms[j];
4984  nsyms -= 1;
4985  }
4986 
4987  i += 1;
4988  }
4989 
4990  /* If all the remaining symbols are identical enumerals, then
4991  just keep the first one and discard the rest.
4992 
4993  Unlike what we did previously, we do not discard any entry
4994  unless they are ALL identical. This is because the symbol
4995  comparison is not a strict comparison, but rather a practical
4996  comparison. If all symbols are considered identical, then
4997  we can just go ahead and use the first one and discard the rest.
4998  But if we cannot reduce the list to a single element, we have
4999  to ask the user to disambiguate anyways. And if we have to
5000  present a multiple-choice menu, it's less confusing if the list
5001  isn't missing some choices that were identical and yet distinct. */
5002  if (symbols_are_identical_enums (syms, nsyms))
5003  nsyms = 1;
5004 
5005  return nsyms;
5006 }
5007 
5008 /* Given a type that corresponds to a renaming entity, use the type name
5009  to extract the scope (package name or function name, fully qualified,
5010  and following the GNAT encoding convention) where this renaming has been
5011  defined. The string returned needs to be deallocated after use. */
5012 
5013 static char *
5014 xget_renaming_scope (struct type *renaming_type)
5015 {
5016  /* The renaming types adhere to the following convention:
5017  <scope>__<rename>___<XR extension>.
5018  So, to extract the scope, we search for the "___XR" extension,
5019  and then backtrack until we find the first "__". */
5020 
5021  const char *name = type_name_no_tag (renaming_type);
5022  char *suffix = strstr (name, "___XR");
5023  char *last;
5024  int scope_len;
5025  char *scope;
5026 
5027  /* Now, backtrack a bit until we find the first "__". Start looking
5028  at suffix - 3, as the <rename> part is at least one character long. */
5029 
5030  for (last = suffix - 3; last > name; last--)
5031  if (last[0] == '_' && last[1] == '_')
5032  break;
5033 
5034  /* Make a copy of scope and return it. */
5035 
5036  scope_len = last - name;
5037  scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
5038 
5039  strncpy (scope, name, scope_len);
5040  scope[scope_len] = '\0';
5041 
5042  return scope;
5043 }
5044 
5045 /* Return nonzero if NAME corresponds to a package name. */
5046 
5047 static int
5048 is_package_name (const char *name)
5049 {
5050  /* Here, We take advantage of the fact that no symbols are generated
5051  for packages, while symbols are generated for each function.
5052  So the condition for NAME represent a package becomes equivalent
5053  to NAME not existing in our list of symbols. There is only one
5054  small complication with library-level functions (see below). */
5055 
5056  char *fun_name;
5057 
5058  /* If it is a function that has not been defined at library level,
5059  then we should be able to look it up in the symbols. */
5060  if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
5061  return 0;
5062 
5063  /* Library-level function names start with "_ada_". See if function
5064  "_ada_" followed by NAME can be found. */
5065 
5066  /* Do a quick check that NAME does not contain "__", since library-level
5067  functions names cannot contain "__" in them. */
5068  if (strstr (name, "__") != NULL)
5069  return 0;
5070 
5071  fun_name = xstrprintf ("_ada_%s", name);
5072 
5073  return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
5074 }
5075 
5076 /* Return nonzero if SYM corresponds to a renaming entity that is
5077  not visible from FUNCTION_NAME. */
5078 
5079 static int
5080 old_renaming_is_invisible (const struct symbol *sym, const char *function_name)
5081 {
5082  char *scope;
5083  struct cleanup *old_chain;
5084 
5085  if (SYMBOL_CLASS (sym) != LOC_TYPEDEF)
5086  return 0;
5087 
5088  scope = xget_renaming_scope (SYMBOL_TYPE (sym));
5089  old_chain = make_cleanup (xfree, scope);
5090 
5091  /* If the rename has been defined in a package, then it is visible. */
5092  if (is_package_name (scope))
5093  {
5094  do_cleanups (old_chain);
5095  return 0;
5096  }
5097 
5098  /* Check that the rename is in the current function scope by checking
5099  that its name starts with SCOPE. */
5100 
5101  /* If the function name starts with "_ada_", it means that it is
5102  a library-level function. Strip this prefix before doing the
5103  comparison, as the encoding for the renaming does not contain
5104  this prefix. */
5105  if (startswith (function_name, "_ada_"))
5106  function_name += 5;
5107 
5108  {
5109  int is_invisible = !startswith (function_name, scope);
5110 
5111  do_cleanups (old_chain);
5112  return is_invisible;
5113  }
5114 }
5115 
5116 /* Remove entries from SYMS that corresponds to a renaming entity that
5117  is not visible from the function associated with CURRENT_BLOCK or
5118  that is superfluous due to the presence of more specific renaming
5119  information. Places surviving symbols in the initial entries of
5120  SYMS and returns the number of surviving symbols.
5121 
5122  Rationale:
5123  First, in cases where an object renaming is implemented as a
5124  reference variable, GNAT may produce both the actual reference
5125  variable and the renaming encoding. In this case, we discard the
5126  latter.
5127 
5128  Second, GNAT emits a type following a specified encoding for each renaming
5129  entity. Unfortunately, STABS currently does not support the definition
5130  of types that are local to a given lexical block, so all renamings types
5131  are emitted at library level. As a consequence, if an application
5132  contains two renaming entities using the same name, and a user tries to
5133  print the value of one of these entities, the result of the ada symbol
5134  lookup will also contain the wrong renaming type.
5135 
5136  This function partially covers for this limitation by attempting to
5137  remove from the SYMS list renaming symbols that should be visible
5138  from CURRENT_BLOCK. However, there does not seem be a 100% reliable
5139  method with the current information available. The implementation
5140  below has a couple of limitations (FIXME: brobecker-2003-05-12):
5141 
5142  - When the user tries to print a rename in a function while there
5143  is another rename entity defined in a package: Normally, the
5144  rename in the function has precedence over the rename in the
5145  package, so the latter should be removed from the list. This is
5146  currently not the case.
5147 
5148  - This function will incorrectly remove valid renames if
5149  the CURRENT_BLOCK corresponds to a function which symbol name
5150  has been changed by an "Export" pragma. As a consequence,
5151  the user will be unable to print such rename entities. */
5152 
5153 static int
5155  int nsyms, const struct block *current_block)
5156 {
5157  struct symbol *current_function;
5158  const char *current_function_name;
5159  int i;
5160  int is_new_style_renaming;
5161 
5162  /* If there is both a renaming foo___XR... encoded as a variable and
5163  a simple variable foo in the same block, discard the latter.
5164  First, zero out such symbols, then compress. */
5165  is_new_style_renaming = 0;
5166  for (i = 0; i < nsyms; i += 1)
5167  {
5168  struct symbol *sym = syms[i].sym;
5169  const struct block *block = syms[i].block;
5170  const char *name;
5171  const char *suffix;
5172 
5173  if (sym == NULL || SYMBOL_CLASS (sym) == LOC_TYPEDEF)
5174  continue;
5175  name = SYMBOL_LINKAGE_NAME (sym);
5176  suffix = strstr (name, "___XR");
5177 
5178  if (suffix != NULL)
5179  {
5180  int name_len = suffix - name;
5181  int j;
5182 
5183  is_new_style_renaming = 1;
5184  for (j = 0; j < nsyms; j += 1)
5185  if (i != j && syms[j].sym != NULL
5186  && strncmp (name, SYMBOL_LINKAGE_NAME (syms[j].sym),
5187  name_len) == 0
5188  && block == syms[j].block)
5189  syms[j].sym = NULL;
5190  }
5191  }
5192  if (is_new_style_renaming)
5193  {
5194  int j, k;
5195 
5196  for (j = k = 0; j < nsyms; j += 1)
5197  if (syms[j].sym != NULL)
5198  {
5199  syms[k] = syms[j];
5200  k += 1;
5201  }
5202  return k;
5203  }
5204 
5205  /* Extract the function name associated to CURRENT_BLOCK.
5206  Abort if unable to do so. */
5207 
5208  if (current_block == NULL)
5209  return nsyms;
5210 
5211  current_function = block_linkage_function (current_block);
5212  if (current_function == NULL)
5213  return nsyms;
5214 
5215  current_function_name = SYMBOL_LINKAGE_NAME (current_function);
5216  if (current_function_name == NULL)
5217  return nsyms;
5218 
5219  /* Check each of the symbols, and remove it from the list if it is
5220  a type corresponding to a renaming that is out of the scope of
5221  the current block. */
5222 
5223  i = 0;
5224  while (i < nsyms)
5225  {
5226  if (ada_parse_renaming (syms[i].sym, NULL, NULL, NULL)
5228  && old_renaming_is_invisible (syms[i].sym, current_function_name))
5229  {
5230  int j;
5231 
5232  for (j = i + 1; j < nsyms; j += 1)
5233  syms[j - 1] = syms[j];
5234  nsyms -= 1;
5235  }
5236  else
5237  i += 1;
5238  }
5239 
5240  return nsyms;
5241 }
5242 
5243 /* Add to OBSTACKP all symbols from BLOCK (and its super-blocks)
5244  whose name and domain match NAME and DOMAIN respectively.
5245  If no match was found, then extend the search to "enclosing"
5246  routines (in other words, if we're inside a nested function,
5247  search the symbols defined inside the enclosing functions).
5248  If WILD_MATCH_P is nonzero, perform the naming matching in
5249  "wild" mode (see function "wild_match" for more info).
5250 
5251  Note: This function assumes that OBSTACKP has 0 (zero) element in it. */
5252 
5253 static void
5254 ada_add_local_symbols (struct obstack *obstackp, const char *name,
5255  const struct block *block, domain_enum domain,
5256  int wild_match_p)
5257 {
5258  int block_depth = 0;
5259 
5260  while (block != NULL)
5261  {
5262  block_depth += 1;
5263  ada_add_block_symbols (obstackp, block, name, domain, NULL,
5264  wild_match_p);
5265 
5266  /* If we found a non-function match, assume that's the one. */
5267  if (is_nonfunction (defns_collected (obstackp, 0),
5268  num_defns_collected (obstackp)))
5269  return;
5270 
5271  block = BLOCK_SUPERBLOCK (block);
5272  }
5273 
5274  /* If no luck so far, try to find NAME as a local symbol in some lexically
5275  enclosing subprogram. */
5276  if (num_defns_collected (obstackp) == 0 && block_depth > 2)
5277  add_symbols_from_enclosing_procs (obstackp, name, domain, wild_match_p);
5278 }
5279 
5280 /* An object of this type is used as the user_data argument when
5281  calling the map_matching_symbols method. */
5282 
5284 {
5285  struct objfile *objfile;
5286  struct obstack *obstackp;
5287  struct symbol *arg_sym;
5289 };
5290 
5291 /* A callback for add_matching_symbols that adds SYM, found in BLOCK,
5292  to a list of symbols. DATA0 is a pointer to a struct match_data *
5293  containing the obstack that collects the symbol list, the file that SYM
5294  must come from, a flag indicating whether a non-argument symbol has
5295  been found in the current block, and the last argument symbol
5296  passed in SYM within the current block (if any). When SYM is null,
5297  marking the end of a block, the argument symbol is added if no
5298  other has been found. */
5299 
5300 static int
5301 aux_add_nonlocal_symbols (struct block *block, struct symbol *sym, void *data0)
5302 {
5303  struct match_data *data = (struct match_data *) data0;
5304 
5305  if (sym == NULL)
5306  {
5307  if (!data->found_sym && data->arg_sym != NULL)
5308  add_defn_to_vec (data->obstackp,
5309  fixup_symbol_section (data->arg_sym, data->objfile),
5310  block);
5311  data->found_sym = 0;
5312  data->arg_sym = NULL;
5313  }
5314  else
5315  {
5316  if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
5317  return 0;
5318  else if (SYMBOL_IS_ARGUMENT (sym))
5319  data->arg_sym = sym;
5320  else
5321  {
5322  data->found_sym = 1;
5323  add_defn_to_vec (data->obstackp,
5324  fixup_symbol_section (sym, data->objfile),
5325  block);
5326  }
5327  }
5328  return 0;
5329 }
5330 
5331 /* Implements compare_names, but only applying the comparision using
5332  the given CASING. */
5333 
5334 static int
5335 compare_names_with_case (const char *string1, const char *string2,
5336  enum case_sensitivity casing)
5337 {
5338  while (*string1 != '\0' && *string2 != '\0')
5339  {
5340  char c1, c2;
5341 
5342  if (isspace (*string1) || isspace (*string2))
5343  return strcmp_iw_ordered (string1, string2);
5344 
5345  if (casing == case_sensitive_off)
5346  {
5347  c1 = tolower (*string1);
5348  c2 = tolower (*string2);
5349  }
5350  else
5351  {
5352  c1 = *string1;
5353  c2 = *string2;
5354  }
5355  if (c1 != c2)
5356  break;
5357 
5358  string1 += 1;
5359  string2 += 1;
5360  }
5361 
5362  switch (*string1)
5363  {
5364  case '(':
5365  return strcmp_iw_ordered (string1, string2);
5366  case '_':
5367  if (*string2 == '\0')
5368  {
5369  if (is_name_suffix (string1))
5370  return 0;
5371  else
5372  return 1;
5373  }
5374  /* FALLTHROUGH */
5375  default:
5376  if (*string2 == '(')
5377  return strcmp_iw_ordered (string1, string2);
5378  else
5379  {
5380  if (casing == case_sensitive_off)
5381  return tolower (*string1) - tolower (*string2);
5382  else
5383  return *string1 - *string2;
5384  }
5385  }
5386 }
5387 
5388 /* Compare STRING1 to STRING2, with results as for strcmp.
5389  Compatible with strcmp_iw_ordered in that...
5390 
5391  strcmp_iw_ordered (STRING1, STRING2) <= 0
5392 
5393  ... implies...
5394 
5395  compare_names (STRING1, STRING2) <= 0
5396 
5397  (they may differ as to what symbols compare equal). */
5398 
5399 static int
5400 compare_names (const char *string1, const char *string2)
5401 {
5402  int result;
5403 
5404  /* Similar to what strcmp_iw_ordered does, we need to perform
5405  a case-insensitive comparison first, and only resort to
5406  a second, case-sensitive, comparison if the first one was
5407  not sufficient to differentiate the two strings. */
5408 
5409  result = compare_names_with_case (string1, string2, case_sensitive_off);
5410  if (result == 0)
5411  result = compare_names_with_case (string1, string2, case_sensitive_on);
5412 
5413  return result;
5414 }
5415 
5416 /* Add to OBSTACKP all non-local symbols whose name and domain match
5417  NAME and DOMAIN respectively. The search is performed on GLOBAL_BLOCK
5418  symbols if GLOBAL is non-zero, or on STATIC_BLOCK symbols otherwise. */
5419 
5420 static void
5421 add_nonlocal_symbols (struct obstack *obstackp, const char *name,
5422  domain_enum domain, int global,
5423  int is_wild_match)
5424 {
5425  struct objfile *objfile;
5426  struct match_data data;
5427 
5428  memset (&data, 0, sizeof data);
5429  data.obstackp = obstackp;
5430 
5431  ALL_OBJFILES (objfile)
5432  {
5433  data.objfile = objfile;
5434 
5435  if (is_wild_match)
5436  objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5437  aux_add_nonlocal_symbols, &data,
5438  wild_match, NULL);
5439  else
5440  objfile->sf->qf->map_matching_symbols (objfile, name, domain, global,
5441  aux_add_nonlocal_symbols, &data,
5443  }
5444 
5445  if (num_defns_collected (obstackp) == 0 && global && !is_wild_match)
5446  {
5447  ALL_OBJFILES (objfile)
5448  {
5449  char *name1 = alloca (strlen (name) + sizeof ("_ada_"));
5450  strcpy (name1, "_ada_");
5451  strcpy (name1 + sizeof ("_ada_") - 1, name);
5452  data.objfile = objfile;
5453  objfile->sf->qf->map_matching_symbols (objfile, name1, domain,
5454  global,
5456  &data,
5458  }
5459  }
5460 }
5461 
5462 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and, if full_search is
5463  non-zero, enclosing scope and in global scopes, returning the number of
5464  matches.
5465  Sets *RESULTS to point to a vector of (SYM,BLOCK) tuples,
5466  indicating the symbols found and the blocks and symbol tables (if
5467  any) in which they were found. This vector is transient---good only to
5468  the next call of ada_lookup_symbol_list.
5469 
5470  When full_search is non-zero, any non-function/non-enumeral
5471  symbol match within the nest of blocks whose innermost member is BLOCK0,
5472  is the one match returned (no other matches in that or
5473  enclosing blocks is returned). If there are any matches in or
5474  surrounding BLOCK0, then these alone are returned.
5475 
5476  Names prefixed with "standard__" are handled specially: "standard__"
5477  is first stripped off, and only static and global symbols are searched. */
5478 
5479 static int
5480 ada_lookup_symbol_list_worker (const char *name0, const struct block *block0,
5481  domain_enum domain,
5482  struct ada_symbol_info **results,
5483  int full_search)
5484 {
5485  struct symbol *sym;
5486  const struct block *block;
5487  const char *name;
5488  const int wild_match_p = should_use_wild_match (name0);
5489  int syms_from_global_search = 0;
5490  int ndefns;
5491 
5492  obstack_free (&symbol_list_obstack, NULL);
5493  obstack_init (&symbol_list_obstack);
5494 
5495  /* Search specified block and its superiors. */
5496 
5497  name = name0;
5498  block = block0;
5499 
5500  /* Special case: If the user specifies a symbol name inside package
5501  Standard, do a non-wild matching of the symbol name without
5502  the "standard__" prefix. This was primarily introduced in order
5503  to allow the user to specifically access the standard exceptions
5504  using, for instance, Standard.Constraint_Error when Constraint_Error
5505  is ambiguous (due to the user defining its own Constraint_Error
5506  entity inside its program). */
5507  if (startswith (name0, "standard__"))
5508  {
5509  block = NULL;
5510  name = name0 + sizeof ("standard__") - 1;
5511  }
5512 
5513  /* Check the non-global symbols. If we have ANY match, then we're done. */
5514 
5515  if (block != NULL)
5516  {
5517  if (full_search)
5518  {
5520  domain, wild_match_p);
5521  }
5522  else
5523  {
5524  /* In the !full_search case we're are being called by
5525  ada_iterate_over_symbols, and we don't want to search
5526  superblocks. */
5528  domain, NULL, wild_match_p);
5529  }
5530  if (num_defns_collected (&symbol_list_obstack) > 0 || !full_search)
5531  goto done;
5532  }
5533 
5534  /* No non-global symbols found. Check our cache to see if we have
5535  already performed this search before. If we have, then return
5536  the same result. */
5537 
5538  if (lookup_cached_symbol (name0, domain, &sym, &block))
5539  {
5540  if (sym != NULL)
5541  add_defn_to_vec (&symbol_list_obstack, sym, block);
5542  goto done;
5543  }
5544 
5545  syms_from_global_search = 1;
5546 
5547  /* Search symbols from all global blocks. */
5548 
5549  add_nonlocal_symbols (&symbol_list_obstack, name, domain, 1,
5550  wild_match_p);
5551 
5552  /* Now add symbols from all per-file blocks if we've gotten no hits
5553  (not strictly correct, but perhaps better than an error). */
5554 
5556  add_nonlocal_symbols (&symbol_list_obstack, name, domain, 0,
5557  wild_match_p);
5558 
5559 done:
5561  *results = defns_collected (&symbol_list_obstack, 1);
5562 
5563  ndefns = remove_extra_symbols (*results, ndefns);
5564 
5565  if (ndefns == 0 && full_search && syms_from_global_search)
5566  cache_symbol (name0, domain, NULL, NULL);
5567 
5568  if (ndefns == 1 && full_search && syms_from_global_search)
5569  cache_symbol (name0, domain, (*results)[0].sym, (*results)[0].block);
5570 
5571  ndefns = remove_irrelevant_renamings (*results, ndefns, block0);
5572 
5573  return ndefns;
5574 }
5575 
5576 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing scope and
5577  in global scopes, returning the number of matches, and setting *RESULTS
5578  to a vector of (SYM,BLOCK) tuples.
5579  See ada_lookup_symbol_list_worker for further details. */
5580 
5581 int
5582 ada_lookup_symbol_list (const char *name0, const struct block *block0,
5583  domain_enum domain, struct ada_symbol_info **results)
5584 {
5585  return ada_lookup_symbol_list_worker (name0, block0, domain, results, 1);
5586 }
5587 
5588 /* Implementation of the la_iterate_over_symbols method. */
5589 
5590 static void
5592  const char *name, domain_enum domain,
5593  symbol_found_callback_ftype *callback,
5594  void *data)
5595 {
5596  int ndefs, i;
5597  struct ada_symbol_info *results;
5598 
5599  ndefs = ada_lookup_symbol_list_worker (name, block, domain, &results, 0);
5600  for (i = 0; i < ndefs; ++i)
5601  {
5602  if (! (*callback) (results[i].sym, data))
5603  break;
5604  }
5605 }
5606 
5607 /* If NAME is the name of an entity, return a string that should
5608  be used to look that entity up in Ada units. This string should
5609  be deallocated after use using xfree.
5610 
5611  NAME can have any form that the "break" or "print" commands might
5612  recognize. In other words, it does not have to be the "natural"
5613  name, or the "encoded" name. */
5614 
5615 char *
5617 {
5618  char *canon;
5619  int nlen = strlen (name);
5620 
5621  if (name[0] == '<' && name[nlen - 1] == '>')
5622  {
5623  canon = xmalloc (nlen - 1);
5624  memcpy (canon, name + 1, nlen - 2);
5625  canon[nlen - 2] = '\0';
5626  }
5627  else
5628  canon = xstrdup (ada_encode (ada_fold_name (name)));
5629  return canon;
5630 }
5631 
5632 /* The result is as for ada_lookup_symbol_list with FULL_SEARCH set
5633  to 1, but choosing the first symbol found if there are multiple
5634  choices.
5635 
5636  The result is stored in *INFO, which must be non-NULL.
5637  If no match is found, INFO->SYM is set to NULL. */
5638 
5639 void
5640 ada_lookup_encoded_symbol (const char *name, const struct block *block,
5641  domain_enum domain,
5642  struct ada_symbol_info *info)
5643 {
5644  struct ada_symbol_info *candidates;
5645  int n_candidates;
5646 
5647  gdb_assert (info != NULL);
5648  memset (info, 0, sizeof (struct ada_symbol_info));
5649 
5650  n_candidates = ada_lookup_symbol_list (name, block, domain, &candidates);
5651  if (n_candidates == 0)
5652  return;
5653 
5654  *info = candidates[0];
5655  info->sym = fixup_symbol_section (info->sym, NULL);
5656 }
5657 
5658 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
5659  scope and in global scopes, or NULL if none. NAME is folded and
5660  encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
5661  choosing the first symbol if there are multiple choices.
5662  If IS_A_FIELD_OF_THIS is not NULL, it is set to zero. */
5663 
5664 struct symbol *
5665 ada_lookup_symbol (const char *name, const struct block *block0,
5666  domain_enum domain, int *is_a_field_of_this)
5667 {
5668  struct ada_symbol_info info;
5669 
5670  if (is_a_field_of_this != NULL)
5671  *is_a_field_of_this = 0;
5672 
5674  block0, domain, &info);
5675  return info.sym;
5676 }
5677 
5678 static struct symbol *
5680  const char *name,
5681  const struct block *block,
5682  const domain_enum domain)
5683 {
5684  struct symbol *sym;
5685 
5686  sym = ada_lookup_symbol (name, block_static_block (block), domain, NULL);
5687  if (sym != NULL)
5688  return sym;
5689 
5690  /* If we haven't found a match at this point, try the primitive
5691  types. In other languages, this search is performed before
5692  searching for global symbols in order to short-circuit that
5693  global-symbol search if it happens that the name corresponds
5694  to a primitive type. But we cannot do the same in Ada, because
5695  it is perfectly legitimate for a program to declare a type which
5696  has the same name as a standard type. If looking up a type in
5697  that situation, we have traditionally ignored the primitive type
5698  in favor of user-defined types. This is why, unlike most other
5699  languages, we search the primitive types this late and only after
5700  having searched the global symbols without success. */
5701 
5702  if (domain == VAR_DOMAIN)
5703  {
5704  struct gdbarch *gdbarch;
5705 
5706  if (block == NULL)
5707  gdbarch = target_gdbarch ();
5708  else
5709  gdbarch = block_gdbarch (block);
5710  sym = language_lookup_primitive_type_as_symbol (langdef, gdbarch, name);
5711  if (sym != NULL)
5712  return sym;
5713  }
5714 
5715  return NULL;
5716 }
5717 
5718 
5719 /* True iff STR is a possible encoded suffix of a normal Ada name
5720  that is to be ignored for matching purposes. Suffixes of parallel
5721  names (e.g., XVE) are not included here. Currently, the possible suffixes
5722  are given by any of the regular expressions:
5723 
5724  [.$][0-9]+ [nested subprogram suffix, on platforms such as GNU/Linux]
5725  ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
5726  TKB [subprogram suffix for task bodies]
5727  _E[0-9]+[bs]$ [protected object entry suffixes]
5728  (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(JM|LJM|X([FDBUP].*|R[^T]?)))?$
5729 
5730  Also, any leading "__[0-9]+" sequence is skipped before the suffix
5731  match is performed. This sequence is used to differentiate homonyms,
5732  is an optional part of a valid name suffix. */
5733 
5734 static int
5735 is_name_suffix (const char *str)
5736 {
5737  int k;
5738  const char *matching;
5739  const int len = strlen (str);
5740 
5741  /* Skip optional leading __[0-9]+. */
5742 
5743  if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
5744  {
5745  str += 3;
5746  while (isdigit (str[0]))
5747  str += 1;
5748  }
5749 
5750  /* [.$][0-9]+ */
5751 
5752  if (str[0] == '.' || str[0] == '$')
5753  {
5754  matching = str + 1;
5755  while (isdigit (matching[0]))
5756  matching += 1;
5757  if (matching[0] == '\0')
5758  return 1;
5759  }
5760 
5761  /* ___[0-9]+ */
5762 
5763  if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
5764  {
5765  matching = str + 3;
5766  while (isdigit (matching[0]))
5767  matching += 1;
5768  if (matching[0] == '\0')
5769  return 1;
5770  }
5771 
5772  /* "TKB" suffixes are used for subprograms implementing task bodies. */
5773 
5774  if (strcmp (str, "TKB") == 0)
5775  return 1;
5776 
5777 #if 0
5778  /* FIXME: brobecker/2005-09-23: Protected Object subprograms end
5779  with a N at the end. Unfortunately, the compiler uses the same
5780  convention for other internal types it creates. So treating
5781  all entity names that end with an "N" as a name suffix causes
5782  some regressions. For instance, consider the case of an enumerated
5783  type. To support the 'Image attribute, it creates an array whose
5784  name ends with N.
5785  Having a single character like this as a suffix carrying some
5786  information is a bit risky. Perhaps we should change the encoding
5787  to be something like "_N" instead. In the meantime, do not do
5788  the following check. */
5789  /* Protected Object Subprograms */
5790  if (len == 1 && str [0] == 'N')
5791  return 1;
5792 #endif
5793 
5794  /* _E[0-9]+[bs]$ */
5795  if (len > 3 && str[0] == '_' && str [1] == 'E' && isdigit (str[2]))
5796  {
5797  matching = str + 3;
5798  while (isdigit (matching[0]))
5799  matching += 1;
5800  if ((matching[0] == 'b' || matching[0] == 's')
5801  && matching [1] == '\0')
5802  return 1;
5803  }
5804 
5805  /* ??? We should not modify STR directly, as we are doing below. This
5806  is fine in this case, but may become problematic later if we find
5807  that this alternative did not work, and want to try matching
5808  another one from the begining of STR. Since we modified it, we
5809  won't be able to find the begining of the string anymore! */
5810  if (str[0] == 'X')
5811  {
5812  str += 1;
5813  while (str[0] != '_' && str[0] != '\0')
5814  {
5815  if (str[0] != 'n' && str[0] != 'b')
5816  return 0;
5817  str += 1;
5818  }
5819  }
5820 
5821  if (str[0] == '\000')
5822  return 1;
5823 
5824  if (str[0] == '_')
5825  {
5826  if (str[1] != '_' || str[2] == '\000')
5827  return 0;
5828  if (str[2] == '_')
5829  {
5830  if (strcmp (str + 3, "JM") == 0)
5831  return 1;
5832  /* FIXME: brobecker/2004-09-30: GNAT will soon stop using
5833  the LJM suffix in favor of the JM one. But we will
5834  still accept LJM as a valid suffix for a reasonable
5835  amount of time, just to allow ourselves to debug programs
5836  compiled using an older version of GNAT. */
5837  if (strcmp (str + 3, "LJM") == 0)
5838  return 1;
5839  if (str[3] != 'X')
5840  return 0;
5841  if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
5842  || str[4] == 'U' || str[4] == 'P')
5843  return 1;
5844  if (str[4] == 'R' && str[5] != 'T')
5845  return 1;
5846  return 0;
5847  }
5848  if (!isdigit (str[2]))
5849  return 0;
5850  for (k = 3; str[k] != '\0'; k += 1)
5851  if (!isdigit (str[k]) && str[k] != '_')
5852  return 0;
5853  return 1;
5854  }
5855  if (str[0] == '$' && isdigit (str[1]))
5856  {
5857  for (k = 2; str[k] != '\0'; k += 1)
5858  if (!isdigit (str[k]) && str[k] != '_')
5859  return 0;
5860  return 1;
5861  }
5862  return 0;
5863 }
5864 
5865 /* Return non-zero if the string starting at NAME and ending before
5866  NAME_END contains no capital letters. */
5867 
5868 static int
5869 is_valid_name_for_wild_match (const char *name0)
5870 {
5871  const char *decoded_name = ada_decode (name0);
5872  int i;
5873 
5874  /* If the decoded name starts with an angle bracket, it means that
5875  NAME0 does not follow the GNAT encoding format. It should then
5876  not be allowed as a possible wild match. */
5877  if (decoded_name[0] == '<')
5878  return 0;
5879 
5880  for (i=0; decoded_name[i] != '\0'; i++)
5881  if (isalpha (decoded_name[i]) && !islower (decoded_name[i]))
5882  return 0;
5883 
5884  return 1;
5885 }
5886 
5887 /* Advance *NAMEP to next occurrence of TARGET0 in the string NAME0
5888  that could start a simple name. Assumes that *NAMEP points into
5889  the string beginning at NAME0. */
5890 
5891 static int
5892 advance_wild_match (const char **namep, const char *name0, int target0)
5893 {
5894  const char *name = *namep;
5895 
5896  while (1)
5897  {
5898  int t0, t1;
5899 
5900  t0 = *name;
5901  if (t0 == '_')
5902  {
5903  t1 = name[1];
5904  if ((t1 >= 'a' && t1 <= 'z') || (t1 >= '0' && t1 <= '9'))
5905  {
5906  name += 1;
5907  if (name == name0 + 5 && startswith (name0, "_ada"))
5908  break;
5909  else
5910  name += 1;
5911  }
5912  else if (t1 == '_' && ((name[2] >= 'a' && name[2] <= 'z')
5913  || name[2] == target0))
5914  {
5915  name += 2;
5916  break;
5917  }
5918  else
5919  return 0;
5920  }
5921  else if ((t0 >= 'a' && t0 <= 'z') || (t0 >= '0' && t0 <= '9'))
5922  name += 1;
5923  else
5924  return 0;
5925  }
5926 
5927  *namep = name;
5928  return 1;
5929 }
5930 
5931 /* Return 0 iff NAME encodes a name of the form prefix.PATN. Ignores any
5932  informational suffixes of NAME (i.e., for which is_name_suffix is
5933  true). Assumes that PATN is a lower-cased Ada simple name. */
5934 
5935 static int
5936 wild_match (const char *name, const char *patn)
5937 {
5938  const char *p;
5939  const char *name0 = name;
5940 
5941  while (1)
5942  {
5943  const char *match = name;
5944 
5945  if (*name == *patn)
5946  {
5947  for (name += 1, p = patn + 1; *p != '\0'; name += 1, p += 1)
5948  if (*p != *name)
5949  break;
5950  if (*p == '\0' && is_name_suffix (name))
5951  return match != name0 && !is_valid_name_for_wild_match (name0);
5952 
5953  if (name[-1] == '_')
5954  name -= 1;
5955  }
5956  if (!advance_wild_match (&name, name0, *patn))
5957  return 1;
5958  }
5959 }
5960 
5961 /* Returns 0 iff symbol name SYM_NAME matches SEARCH_NAME, apart from
5962  informational suffix. */
5963 
5964 static int
5965 full_match (const char *sym_name, const char *search_name)
5966 {
5967  return !match_name (sym_name, search_name, 0);
5968 }
5969 
5970 
5971 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5972  vector *defn_symbols, updating the list of symbols in OBSTACKP
5973  (if necessary). If WILD, treat as NAME with a wildcard prefix.
5974  OBJFILE is the section containing BLOCK. */
5975 
5976 static void
5977 ada_add_block_symbols (struct obstack *obstackp,
5978  const struct block *block, const char *name,
5979  domain_enum domain, struct objfile *objfile,
5980  int wild)
5981 {
5982  struct block_iterator iter;
5983  int name_len = strlen (name);
5984  /* A matching argument symbol, if any. */
5985  struct symbol *arg_sym;
5986  /* Set true when we find a matching non-argument symbol. */
5987  int found_sym;
5988  struct symbol *sym;
5989 
5990  arg_sym = NULL;
5991  found_sym = 0;
5992  if (wild)
5993  {
5994  for (sym = block_iter_match_first (block, name, wild_match, &iter);
5995  sym != NULL; sym = block_iter_match_next (name, wild_match, &iter))
5996  {
5998  SYMBOL_DOMAIN (sym), domain)
5999  && wild_match (SYMBOL_LINKAGE_NAME (sym), name) == 0)
6000  {
6001  if (SYMBOL_CLASS (sym) == LOC_UNRESOLVED)
6002  continue;
6003  else if (SYMBOL_IS_ARGUMENT (sym))
6004  arg_sym = sym;
6005  else
6006  {
6007  found_sym = 1;
6008  add_defn_to_vec (obstackp,
6009  fixup_symbol_section (sym, objfile),
6010  block);
6011  }
6012  }
6013  }
6014  }
6015  else
6016  {
6017  for (sym = block_iter_match_first (block, name, full_match, &iter);
6018  sym != NULL; sym = block_iter_match_next (name, full_match, &iter))
6019  {
6021  SYMBOL_DOMAIN (sym), domain))
6022  {
6023  if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6024  {
6025  if (SYMBOL_IS_ARGUMENT (sym))
6026  arg_sym = sym;
6027  else
6028  {
6029  found_sym = 1;
6030  add_defn_to_vec (obstackp,
6031  fixup_symbol_section (sym, objfile),
6032  block);
6033  }
6034  }
6035  }
6036  }
6037  }
6038 
6039  if (!found_sym && arg_sym != NULL)
6040  {
6041  add_defn_to_vec (obstackp,
6042  fixup_symbol_section (arg_sym, objfile),
6043  block);
6044  }
6045 
6046  if (!wild)
6047  {
6048  arg_sym = NULL;
6049  found_sym = 0;
6050 
6051  ALL_BLOCK_SYMBOLS (block, iter, sym)
6052  {
6054  SYMBOL_DOMAIN (sym), domain))
6055  {
6056  int cmp;
6057 
6058  cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
6059  if (cmp == 0)
6060  {
6061  cmp = !startswith (SYMBOL_LINKAGE_NAME (sym), "_ada_");
6062  if (cmp == 0)
6063  cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
6064  name_len);
6065  }
6066 
6067  if (cmp == 0
6068  && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
6069  {
6070  if (SYMBOL_CLASS (sym) != LOC_UNRESOLVED)
6071  {
6072  if (SYMBOL_IS_ARGUMENT (sym))
6073  arg_sym = sym;
6074  else
6075  {
6076  found_sym = 1;
6077  add_defn_to_vec (obstackp,
6078  fixup_symbol_section (sym, objfile),
6079  block);
6080  }
6081  }
6082  }
6083  }
6084  }
6085 
6086  /* NOTE: This really shouldn't be needed for _ada_ symbols.
6087  They aren't parameters, right? */
6088  if (!found_sym && arg_sym != NULL)
6089  {
6090  add_defn_to_vec (obstackp,
6091  fixup_symbol_section (arg_sym, objfile),
6092  block);
6093  }
6094  }
6095 }
6096 
6097 
6098  /* Symbol Completion */
6099 
6100 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
6101  name in a form that's appropriate for the completion. The result
6102  does not need to be deallocated, but is only good until the next call.
6103 
6104  TEXT_LEN is equal to the length of TEXT.
6105  Perform a wild match if WILD_MATCH_P is set.
6106  ENCODED_P should be set if TEXT represents the start of a symbol name
6107  in its encoded form. */
6108 
6109 static const char *
6110 symbol_completion_match (const char *sym_name,
6111  const char *text, int text_len,
6112  int wild_match_p, int encoded_p)
6113 {
6114  const int verbatim_match = (text[0] == '<');
6115  int match = 0;
6116 
6117  if (verbatim_match)
6118  {
6119  /* Strip the leading angle bracket. */
6120  text = text + 1;
6121  text_len--;
6122  }
6123 
6124  /* First, test against the fully qualified name of the symbol. */
6125 
6126  if (strncmp (sym_name, text, text_len) == 0)
6127  match = 1;
6128 
6129  if (match && !encoded_p)
6130  {
6131  /* One needed check before declaring a positive match is to verify
6132  that iff we are doing a verbatim match, the decoded version
6133  of the symbol name starts with '<'. Otherwise, this symbol name
6134  is not a suitable completion. */
6135  const char *sym_name_copy = sym_name;
6136  int has_angle_bracket;
6137 
6138  sym_name = ada_decode (sym_name);
6139  has_angle_bracket = (sym_name[0] == '<');
6140  match = (has_angle_bracket == verbatim_match);
6141  sym_name = sym_name_copy;
6142  }
6143 
6144  if (match && !verbatim_match)
6145  {
6146  /* When doing non-verbatim match, another check that needs to
6147  be done is to verify that the potentially matching symbol name
6148  does not include capital letters, because the ada-mode would
6149  not be able to understand these symbol names without the
6150  angle bracket notation. */
6151  const char *tmp;
6152 
6153  for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
6154  if (*tmp != '\0')
6155  match = 0;
6156  }
6157 
6158  /* Second: Try wild matching... */
6159 
6160  if (!match && wild_match_p)
6161  {
6162  /* Since we are doing wild matching, this means that TEXT
6163  may represent an unqualified symbol name. We therefore must
6164  also compare TEXT against the unqualified name of the symbol. */
6165  sym_name = ada_unqualified_name (ada_decode (sym_name));
6166 
6167  if (strncmp (sym_name, text, text_len) == 0)
6168  match = 1;
6169  }
6170 
6171  /* Finally: If we found a mach, prepare the result to return. */
6172 
6173  if (!match)
6174  return NULL;
6175 
6176  if (verbatim_match)
6177  sym_name = add_angle_brackets (sym_name);
6178 
6179  if (!encoded_p)
6180  sym_name = ada_decode (sym_name);
6181 
6182  return sym_name;
6183 }
6184 
6185 /* A companion function to ada_make_symbol_completion_list().
6186  Check if SYM_NAME represents a symbol which name would be suitable
6187  to complete TEXT (TEXT_LEN is the length of TEXT), in which case
6188  it is appended at the end of the given string vector SV.
6189 
6190  ORIG_TEXT is the string original string from the user command
6191  that needs to be completed. WORD is the entire command on which
6192  completion should be performed. These two parameters are used to
6193  determine which part of the symbol name should be added to the
6194  completion vector.
6195  if WILD_MATCH_P is set, then wild matching is performed.
6196  ENCODED_P should be set if TEXT represents a symbol name in its
6197  encoded formed (in which case the completion should also be
6198  encoded). */
6199 
6200 static void
6202  const char *sym_name,
6203  const char *text, int text_len,
6204  const char *orig_text, const char *word,
6205  int wild_match_p, int encoded_p)
6206 {
6207  const char *match = symbol_completion_match (sym_name, text, text_len,
6208  wild_match_p, encoded_p);
6209  char *completion;
6210 
6211  if (match == NULL)
6212  return;
6213 
6214  /* We found a match, so add the appropriate completion to the given
6215  string vector. */
6216 
6217  if (word == orig_text)
6218  {
6219  completion = xmalloc (strlen (match) + 5);
6220  strcpy (completion, match);
6221  }
6222  else if (word > orig_text)
6223  {
6224  /* Return some portion of sym_name. */
6225  completion = xmalloc (strlen (match) + 5);
6226  strcpy (completion, match + (word - orig_text));
6227  }
6228  else
6229  {
6230  /* Return some of ORIG_TEXT plus sym_name. */
6231  completion = xmalloc (strlen (match) + (orig_text - word) + 5);
6232  strncpy (completion, word, orig_text - word);
6233  completion[orig_text - word] = '\0';
6234  strcat (completion, match);
6235  }
6236 
6237  VEC_safe_push (char_ptr, *sv, completion);
6238 }
6239 
6240 /* An object of this type is passed as the user_data argument to the
6241  expand_symtabs_matching method. */
6243 {
6244  VEC(char_ptr) **completions;
6245  const char *text;
6246  int text_len;
6247  const char *text0;
6248  const char *word;
6249  int wild_match;
6250  int encoded;
6251 };
6252 
6253 /* A callback for expand_symtabs_matching. */
6254 
6255 static int
6256 ada_complete_symbol_matcher (const char *name, void *user_data)
6257 {
6258  struct add_partial_datum *data = user_data;
6259 
6260  return symbol_completion_match (name, data->text, data->text_len,
6261  data->wild_match, data->encoded) != NULL;
6262 }
6263 
6264 /* Return a list of possible symbol names completing TEXT0. WORD is
6265  the entire command on which completion is made. */
6266 
6267 static VEC (char_ptr) *
6268 ada_make_symbol_completion_list (const char *text0, const char *word,
6269  enum type_code code)
6270 {
6271  char *text;
6272  int text_len;
6273  int wild_match_p;
6274  int encoded_p;
6275  VEC(char_ptr) *completions = VEC_alloc (char_ptr, 128);
6276  struct symbol *sym;
6277  struct compunit_symtab *s;
6278  struct minimal_symbol *msymbol;
6279  struct objfile *objfile;
6280  const struct block *b, *surrounding_static_block = 0;
6281  int i;
6282  struct block_iterator iter;
6283  struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
6284 
6285  gdb_assert (code == TYPE_CODE_UNDEF);
6286 
6287  if (text0[0] == '<')
6288  {
6289  text = xstrdup (text0);
6290  make_cleanup (xfree, text);
6291  text_len = strlen (text);
6292  wild_match_p = 0;
6293  encoded_p = 1;
6294  }
6295  else
6296  {
6297  text = xstrdup (ada_encode (text0));
6298  make_cleanup (xfree, text);
6299  text_len = strlen (text);
6300  for (i = 0; i < text_len; i++)
6301  text[i] = tolower (text[i]);
6302 
6303  encoded_p = (strstr (text0, "__") != NULL);
6304  /* If the name contains a ".", then the user is entering a fully
6305  qualified entity name, and the match must not be done in wild
6306  mode. Similarly, if the user wants to complete what looks like
6307  an encoded name, the match must not be done in wild mode. */
6308  wild_match_p = (strchr (text0, '.') == NULL && !encoded_p);
6309  }
6310 
6311  /* First, look at the partial symtab symbols. */
6312  {
6313  struct add_partial_datum data;
6314 
6315  data.completions = &completions;
6316  data.text = text;
6317  data.text_len = text_len;
6318  data.text0 = text0;
6319  data.word = word;
6320  data.wild_match = wild_match_p;
6321  data.encoded = encoded_p;
6323  ALL_DOMAIN, &data);
6324  }
6325 
6326  /* At this point scan through the misc symbol vectors and add each
6327  symbol you find to the list. Eventually we want to ignore
6328  anything that isn't a text symbol (everything else will be
6329  handled by the psymtab code above). */
6330 
6331  ALL_MSYMBOLS (objfile, msymbol)
6332  {
6333  QUIT;
6334  symbol_completion_add (&completions, MSYMBOL_LINKAGE_NAME (msymbol),
6335  text, text_len, text0, word, wild_match_p,
6336  encoded_p);
6337  }
6338 
6339  /* Search upwards from currently selected frame (so that we can
6340  complete on local vars. */
6341 
6342  for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
6343  {
6344  if (!BLOCK_SUPERBLOCK (b))
6345  surrounding_static_block = b; /* For elmin of dups */
6346 
6347  ALL_BLOCK_SYMBOLS (b, iter, sym)
6348  {
6349  symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
6350  text, text_len, text0, word,
6351  wild_match_p, encoded_p);
6352  }
6353  }
6354 
6355  /* Go through the symtabs and check the externs and statics for
6356  symbols which match. */
6357 
6358  ALL_COMPUNITS (objfile, s)
6359  {
6360  QUIT;
6362  ALL_BLOCK_SYMBOLS (b, iter, sym)
6363  {
6364  symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
6365  text, text_len, text0, word,
6366  wild_match_p, encoded_p);
6367  }
6368  }
6369 
6370  ALL_COMPUNITS (objfile, s)
6371  {
6372  QUIT;
6374  /* Don't do this block twice. */
6375  if (b == surrounding_static_block)
6376  continue;
6377  ALL_BLOCK_SYMBOLS (b, iter, sym)
6378  {
6379  symbol_completion_add (&completions, SYMBOL_LINKAGE_NAME (sym),
6380  text, text_len, text0, word,
6381  wild_match_p, encoded_p);
6382  }
6383  }
6384 
6385  do_cleanups (old_chain);
6386  return completions;
6387 }
6388 
6389  /* Field Access */
6390 
6391 /* Return non-zero if TYPE is a pointer to the GNAT dispatch table used
6392  for tagged types. */
6393 
6394 static int
6396 {
6397  const char *name;
6398 
6399  if (TYPE_CODE (type) != TYPE_CODE_PTR)
6400  return 0;
6401 
6402  name = TYPE_NAME (TYPE_TARGET_TYPE (type));
6403  if (name == NULL)
6404  return 0;
6405 
6406  return (strcmp (name, "ada__tags__dispatch_table") == 0);
6407 }
6408 
6409 /* Return non-zero if TYPE is an interface tag. */
6410 
6411 static int
6413 {
6414  const char *name = TYPE_NAME (type);
6415 
6416  if (name == NULL)
6417  return 0;
6418 
6419  return (strcmp (name, "ada__tags__interface_tag") == 0);
6420 }
6421 
6422 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6423  to be invisible to users. */
6424 
6425 int
6426 ada_is_ignored_field (struct type *type, int field_num)
6427 {
6428  if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6429  return 1;
6430 
6431  /* Check the name of that field. */
6432  {
6433  const char *name = TYPE_FIELD_NAME (type, field_num);
6434 
6435  /* Anonymous field names should not be printed.
6436  brobecker/2007-02-20: I don't think this can actually happen
6437  but we don't want to print the value of annonymous fields anyway. */
6438  if (name == NULL)
6439  return 1;
6440 
6441  /* Normally, fields whose name start with an underscore ("_")
6442  are fields that have been internally generated by the compiler,
6443  and thus should not be printed. The "_parent" field is special,
6444  however: This is a field internally generated by the compiler
6445  for tagged types, and it contains the components inherited from
6446  the parent type. This field should not be printed as is, but
6447  should not be ignored either. */
6448  if (name[0] == '_' && !startswith (name, "_parent"))
6449  return 1;
6450  }
6451 
6452  /* If this is the dispatch table of a tagged type or an interface tag,
6453  then ignore. */
6454  if (ada_is_tagged_type (type, 1)
6455  && (ada_is_dispatch_table_ptr_type (TYPE_FIELD_TYPE (type, field_num))
6456  || ada_is_interface_tag (TYPE_FIELD_TYPE (type, field_num))))
6457  return 1;
6458 
6459  /* Not a special field, so it should not be ignored. */
6460  return 0;
6461 }
6462 
6463 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6464  pointer or reference type whose ultimate target has a tag field. */
6465 
6466 int
6467 ada_is_tagged_type (struct type *type, int refok)
6468 {
6469  return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6470 }
6471 
6472 /* True iff TYPE represents the type of X'Tag */
6473 
6474 int
6476 {
6477  type = ada_check_typedef (type);
6478 
6479  if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
6480  return 0;
6481  else
6482  {
6483  const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6484 
6485  return (name != NULL
6486  && strcmp (name, "ada__tags__dispatch_table") == 0);
6487  }
6488 }
6489 
6490 /* The type of the tag on VAL. */
6491 
6492 struct type *
6493 ada_tag_type (struct value *val)
6494 {
6495  return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
6496 }
6497 
6498 /* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
6499  retired at Ada 05). */
6500 
6501 static int
6502 is_ada95_tag (struct value *tag)
6503 {
6504  return ada_value_struct_elt (tag, "tsd", 1) != NULL;
6505 }
6506 
6507 /* The value of the tag on VAL. */
6508 
6509 struct value *
6510 ada_value_tag (struct value *val)
6511 {
6512  return ada_value_struct_elt (val, "_tag", 0);
6513 }
6514 
6515 /* The value of the tag on the object of type TYPE whose contents are
6516  saved at VALADDR, if it is non-null, or is at memory address
6517  ADDRESS. */
6518 
6519 static struct value *
6521  const gdb_byte *valaddr,
6523 {
6524  int tag_byte_offset;
6525  struct type *tag_type;
6526 
6527  if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
6528  NULL, NULL, NULL))
6529  {
6530  const gdb_byte *valaddr1 = ((valaddr == NULL)
6531  ? NULL
6532  : valaddr + tag_byte_offset);
6533  CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6534 
6535  return value_from_contents_and_address (tag_type, valaddr1, address1);
6536  }
6537  return NULL;
6538 }
6539 
6540 static struct type *
6541 type_from_tag (struct value *tag)
6542 {
6543  const char *type_name = ada_tag_name (tag);
6544 
6545  if (type_name != NULL)
6546  return ada_find_any_type (ada_encode (type_name));
6547  return NULL;
6548 }
6549 
6550 /* Given a value OBJ of a tagged type, return a value of this
6551  type at the base address of the object. The base address, as
6552  defined in Ada.Tags, it is the address of the primary tag of
6553  the object, and therefore where the field values of its full
6554  view can be fetched. */
6555 
6556 struct value *
6558 {
6559  struct value *val;
6560  LONGEST offset_to_top = 0;
6561  struct type *ptr_type, *obj_type;
6562  struct value *tag;
6563  CORE_ADDR base_address;
6564 
6565  obj_type = value_type (obj);
6566 
6567  /* It is the responsability of the caller to deref pointers. */
6568 
6569  if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
6570  || TYPE_CODE (obj_type) == TYPE_CODE_REF)
6571  return obj;
6572 
6573  tag = ada_value_tag (obj);
6574  if (!tag)
6575  return obj;
6576 
6577  /* Base addresses only appeared with Ada 05 and multiple inheritance. */
6578 
6579  if (is_ada95_tag (tag))
6580  return obj;
6581 
6582  ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
6583  ptr_type = lookup_pointer_type (ptr_type);
6584  val = value_cast (ptr_type, tag);
6585  if (!val)
6586  return obj;
6587 
6588  /* It is perfectly possible that an exception be raised while
6589  trying to determine the base address, just like for the tag;
6590  see ada_tag_name for more details. We do not print the error
6591  message for the same reason. */
6592 
6593  TRY
6594  {
6595  offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
6596  }
6597 
6599  {
6600  return obj;
6601  }
6602  END_CATCH
6603 
6604  /* If offset is null, nothing to do. */
6605 
6606  if (offset_to_top == 0)
6607  return obj;
6608 
6609  /* -1 is a special case in Ada.Tags; however, what should be done
6610  is not quite clear from the documentation. So do nothing for
6611  now. */
6612 
6613  if (offset_to_top == -1)
6614  return obj;
6615 
6616  base_address = value_address (obj) - offset_to_top;
6617  tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
6618 
6619  /* Make sure that we have a proper tag at the new address.
6620  Otherwise, offset_to_top is bogus (which can happen when
6621  the object is not initialized yet). */
6622 
6623  if (!tag)
6624  return obj;
6625 
6626  obj_type = type_from_tag (tag);
6627 
6628  if (!obj_type)
6629  return obj;
6630 
6631  return value_from_contents_and_address (obj_type, NULL, base_address);
6632 }
6633 
6634 /* Return the "ada__tags__type_specific_data" type. */
6635 
6636 static struct type *
6638 {
6639  struct ada_inferior_data *data = get_ada_inferior_data (inf);
6640 
6641  if (data->tsd_type == 0)
6642  data->tsd_type = ada_find_any_type ("ada__tags__type_specific_data");
6643  return data->tsd_type;
6644 }
6645 
6646 /* Return the TSD (type-specific data) associated to the given TAG.
6647  TAG is assumed to be the tag of a tagged-type entity.
6648 
6649  May return NULL if we are unable to get the TSD. */
6650 
6651 static struct value *
6653 {
6654  struct value *val;
6655  struct type *type;
6656 
6657  /* First option: The TSD is simply stored as a field of our TAG.
6658  Only older versions of GNAT would use this format, but we have
6659  to test it first, because there are no visible markers for
6660  the current approach except the absence of that field. */
6661 
6662  val = ada_value_struct_elt (tag, "tsd", 1);
6663  if (val)
6664  return val;
6665 
6666  /* Try the second representation for the dispatch table (in which
6667  there is no explicit 'tsd' field in the referent of the tag pointer,
6668  and instead the tsd pointer is stored just before the dispatch
6669  table. */
6670 
6672  if (type == NULL)
6673  return NULL;
6674  type = lookup_pointer_type (lookup_pointer_type (type));
6675  val = value_cast (type, tag);
6676  if (val == NULL)
6677  return NULL;
6678  return value_ind (value_ptradd (val, -1));
6679 }
6680 
6681 /* Given the TSD of a tag (type-specific data), return a string
6682  containing the name of the associated type.
6683 
6684  The returned value is good until the next call. May return NULL
6685  if we are unable to determine the tag name. */
6686 
6687 static char *
6689 {
6690  static char name[1024];
6691  char *p;
6692  struct value *val;
6693 
6694  val = ada_value_struct_elt (tsd, "expanded_name", 1);
6695  if (val == NULL)
6696  return NULL;
6697  read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6698  for (p = name; *p != '\0'; p += 1)
6699  if (isalpha (*p))
6700  *p = tolower (*p);
6701  return name;
6702 }
6703 
6704 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6705  a C string.
6706 
6707  Return NULL if the TAG is not an Ada tag, or if we were unable to
6708  determine the name of that tag. The result is good until the next
6709  call. */
6710 
6711 const char *
6712 ada_tag_name (struct value *tag)
6713 {
6714  char *name = NULL;
6715 
6716  if (!ada_is_tag_type (value_type (tag)))
6717  return NULL;
6718 
6719  /* It is perfectly possible that an exception be raised while trying
6720  to determine the TAG's name, even under normal circumstances:
6721  The associated variable may be uninitialized or corrupted, for
6722  instance. We do not let any exception propagate past this point.
6723  instead we return NULL.
6724 
6725  We also do not print the error message either (which often is very
6726  low-level (Eg: "Cannot read memory at 0x[...]"), but instead let
6727  the caller print a more meaningful message if necessary. */
6728  TRY
6729  {
6730  struct value *tsd = ada_get_tsd_from_tag (tag);
6731 
6732  if (tsd != NULL)
6733  name = ada_tag_name_from_tsd (tsd);
6734  }
6736  {
6737  }
6738  END_CATCH
6739 
6740  return name;
6741 }
6742 
6743 /* The parent type of TYPE, or NULL if none. */
6744 
6745 struct type *
6747 {
6748  int i;
6749 
6750  type = ada_check_typedef (type);
6751 
6752  if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6753  return NULL;
6754 
6755  for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6756  if (ada_is_parent_field (type, i))
6757  {
6758  struct type *parent_type = TYPE_FIELD_TYPE (type, i);
6759 
6760  /* If the _parent field is a pointer, then dereference it. */
6761  if (TYPE_CODE (parent_type) == TYPE_CODE_PTR)
6762  parent_type = TYPE_TARGET_TYPE (parent_type);
6763  /* If there is a parallel XVS type, get the actual base type. */
6764  parent_type = ada_get_base_type (parent_type);
6765 
6766  return ada_check_typedef (parent_type);
6767  }
6768 
6769  return NULL;
6770 }
6771 
6772 /* True iff field number FIELD_NUM of structure type TYPE contains the
6773  parent-type (inherited) fields of a derived type. Assumes TYPE is
6774  a structure type with at least FIELD_NUM+1 fields. */
6775 
6776 int
6777 ada_is_parent_field (struct type *type, int field_num)
6778 {
6779  const char *name = TYPE_FIELD_NAME (ada_check_typedef (type), field_num);
6780 
6781  return (name != NULL
6782  && (startswith (name, "PARENT")
6783  || startswith (name, "_parent")));
6784 }
6785 
6786 /* True iff field number FIELD_NUM of structure type TYPE is a
6787  transparent wrapper field (which should be silently traversed when doing
6788  field selection and flattened when printing). Assumes TYPE is a
6789  structure type with at least FIELD_NUM+1 fields. Such fields are always
6790  structures. */
6791 
6792 int
6793 ada_is_wrapper_field (struct type *type, int field_num)
6794 {
6795  const char *name = TYPE_FIELD_NAME (type, field_num);
6796 
6797  return (name != NULL
6798  && (startswith (name, "PARENT")
6799  || strcmp (name, "REP") == 0
6800  || startswith (name, "_parent")
6801  || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
6802 }
6803 
6804 /* True iff field number FIELD_NUM of structure or union type TYPE
6805  is a variant wrapper. Assumes TYPE is a structure type with at least
6806  FIELD_NUM+1 fields. */
6807 
6808 int
6809 ada_is_variant_part (struct type *type, int field_num)
6810 {
6811  struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
6812 
6813  return (TYPE_CODE (field_type) == TYPE_CODE_UNION
6814  || (is_dynamic_field (type, field_num)
6815  && (TYPE_CODE (TYPE_TARGET_TYPE (field_type))
6816  == TYPE_CODE_UNION)));
6817 }
6818 
6819 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6820  whose discriminants are contained in the record type OUTER_TYPE,
6821  returns the type of the controlling discriminant for the variant.
6822  May return NULL if the type could not be found. */
6823 
6824 struct type *
6825 ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
6826 {
6827  char *name = ada_variant_discrim_name (var_type);
6828 
6829  return ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
6830 }
6831 
6832 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6833  valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6834  represents a 'when others' clause; otherwise 0. */
6835 
6836 int
6837 ada_is_others_clause (struct type *type, int field_num)
6838 {
6839  const char *name = TYPE_FIELD_NAME (type, field_num);
6840 
6841  return (name != NULL && name[0] == 'O');
6842 }
6843 
6844 /* Assuming that TYPE0 is the type of the variant part of a record,
6845  returns the name of the discriminant controlling the variant.
6846  The value is valid until the next call to ada_variant_discrim_name. */
6847 
6848 char *
6850 {
6851  static char *result = NULL;
6852  static size_t result_len = 0;
6853  struct type *type;
6854  const char *name;
6855  const char *discrim_end;
6856  const char *discrim_start;
6857 
6858  if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6859  type = TYPE_TARGET_TYPE (type0);
6860  else
6861  type = type0;
6862 
6863  name = ada_type_name (type);
6864 
6865  if (name == NULL || name[0] == '\000')
6866  return "";
6867 
6868  for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6869  discrim_end -= 1)
6870  {
6871  if (startswith (discrim_end, "___XVN"))
6872  break;
6873  }
6874  if (discrim_end == name)
6875  return "";
6876 
6877  for (discrim_start = discrim_end; discrim_start != name + 3;
6878  discrim_start -= 1)
6879  {
6880  if (discrim_start == name + 1)
6881  return "";
6882  if ((discrim_start > name + 3
6883  && startswith (discrim_start - 3, "___"))
6884  || discrim_start[-1] == '.')
6885  break;
6886  }
6887 
6888  GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6889  strncpy (result, discrim_start, discrim_end - discrim_start);
6890  result[discrim_end - discrim_start] = '\0';
6891  return result;
6892 }
6893 
6894 /* Scan STR for a subtype-encoded number, beginning at position K.
6895  Put the position of the character just past the number scanned in
6896  *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6897  Return 1 if there was a valid number at the given position, and 0
6898  otherwise. A "subtype-encoded" number consists of the absolute value
6899  in decimal, followed by the letter 'm' to indicate a negative number.
6900  Assumes 0m does not occur. */
6901 
6902 int
6903 ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
6904 {
6905  ULONGEST RU;
6906 
6907  if (!isdigit (str[k]))
6908  return 0;
6909 
6910  /* Do it the hard way so as not to make any assumption about
6911  the relationship of unsigned long (%lu scan format code) and
6912  LONGEST. */
6913  RU = 0;
6914  while (isdigit (str[k]))
6915  {
6916  RU = RU * 10 + (str[k] - '0');
6917  k += 1;
6918  }
6919 
6920  if (str[k] == 'm')
6921  {
6922  if (R != NULL)
6923  *R = (-(LONGEST) (RU - 1)) - 1;
6924  k += 1;
6925  }
6926  else if (R != NULL)
6927  *R = (LONGEST) RU;
6928 
6929  /* NOTE on the above: Technically, C does not say what the results of
6930  - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6931  number representable as a LONGEST (although either would probably work
6932  in most implementations). When RU>0, the locution in the then branch
6933  above is always equivalent to the negative of RU. */
6934 
6935  if (new_k != NULL)
6936  *new_k = k;
6937  return 1;
6938 }
6939 
6940 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6941  and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6942  in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6943 
6944 int
6945 ada_in_variant (LONGEST val, struct type *type, int field_num)
6946 {
6947  const char *name = TYPE_FIELD_NAME (type, field_num);
6948  int p;
6949 
6950  p = 0;
6951  while (1)
6952  {
6953  switch (name[p])
6954  {
6955  case '\0':
6956  return 0;
6957  case 'S':
6958  {
6959  LONGEST W;
6960 
6961  if (!ada_scan_number (name, p + 1, &W, &p))
6962  return 0;
6963  if (val == W)
6964  return 1;
6965  break;
6966  }
6967  case 'R':
6968  {
6969  LONGEST L, U;
6970 
6971  if (!ada_scan_number (name, p + 1, &L, &p)
6972  || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6973  return 0;
6974  if (val >= L && val <= U)
6975  return 1;
6976  break;
6977  }
6978  case 'O':
6979  return 1;
6980  default:
6981  return 0;
6982  }
6983  }
6984 }
6985 
6986 /* FIXME: Lots of redundancy below. Try to consolidate. */
6987 
6988 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6989  ARG_TYPE, extract and return the value of one of its (non-static)
6990  fields. FIELDNO says which field. Differs from value_primitive_field
6991  only in that it can handle packed values of arbitrary type. */
6992 
6993 static struct value *
6994 ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
6995  struct type *arg_type)
6996 {
6997  struct type *type;
6998 
6999  arg_type = ada_check_typedef (arg_type);
7000  type = TYPE_FIELD_TYPE (arg_type, fieldno);
7001 
7002  /* Handle packed fields. */
7003 
7004  if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
7005  {
7006  int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
7007  int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
7008 
7009  return ada_value_primitive_packed_val (arg1, value_contents (arg1),
7010  offset + bit_pos / 8,
7011  bit_pos % 8, bit_size, type);
7012  }
7013  else
7014  return value_primitive_field (arg1, offset, fieldno, arg_type);
7015 }
7016 
7017 /* Find field with name NAME in object of type TYPE. If found,
7018  set the following for each argument that is non-null:
7019  - *FIELD_TYPE_P to the field's type;
7020  - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within
7021  an object of that type;
7022  - *BIT_OFFSET_P to the bit offset modulo byte size of the field;
7023  - *BIT_SIZE_P to its size in bits if the field is packed, and
7024  0 otherwise;
7025  If INDEX_P is non-null, increment *INDEX_P by the number of source-visible
7026  fields up to but not including the desired field, or by the total
7027  number of fields if not found. A NULL value of NAME never
7028  matches; the function just counts visible fields in this case.
7029 
7030  Returns 1 if found, 0 otherwise. */
7031 
7032 static int
7033 find_struct_field (const char *name, struct type *type, int offset,
7034  struct type **field_type_p,
7035  int *byte_offset_p, int *bit_offset_p, int *bit_size_p,
7036  int *index_p)
7037 {
7038  int i;
7039 
7040  type = ada_check_typedef (type);
7041 
7042  if (field_type_p != NULL)
7043  *field_type_p = NULL;
7044  if (byte_offset_p != NULL)
7045  *byte_offset_p = 0;
7046  if (bit_offset_p != NULL)
7047  *bit_offset_p = 0;
7048  if (bit_size_p != NULL)
7049  *bit_size_p = 0;
7050 
7051  for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7052  {
7053  int bit_pos = TYPE_FIELD_BITPOS (type, i);
7054  int fld_offset = offset + bit_pos / 8;
7055  const char *t_field_name = TYPE_FIELD_NAME (type, i);
7056 
7057  if (t_field_name == NULL)
7058  continue;
7059 
7060  else if (name != NULL && field_name_match (t_field_name, name))
7061  {
7062  int bit_size = TYPE_FIELD_BITSIZE (type, i);
7063 
7064  if (field_type_p != NULL)
7065  *field_type_p = TYPE_FIELD_TYPE (type, i);
7066  if (byte_offset_p != NULL)
7067  *byte_offset_p = fld_offset;
7068  if (bit_offset_p != NULL)
7069  *bit_offset_p = bit_pos % 8;
7070  if (bit_size_p != NULL)
7071  *bit_size_p = bit_size;
7072  return 1;
7073  }
7074  else if (ada_is_wrapper_field (type, i))
7075  {
7076  if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
7077  field_type_p, byte_offset_p, bit_offset_p,
7078  bit_size_p, index_p))
7079  return 1;
7080  }
7081  else if (ada_is_variant_part (type, i))
7082  {
7083  /* PNH: Wait. Do we ever execute this section, or is ARG always of
7084  fixed type?? */
7085  int j;
7086  struct type *field_type
7087  = ada_check_typedef (TYPE_FIELD_TYPE (type, i));
7088 
7089  for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7090  {
7091  if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
7092  fld_offset
7093  + TYPE_FIELD_BITPOS (field_type, j) / 8,
7094  field_type_p, byte_offset_p,
7095  bit_offset_p, bit_size_p, index_p))
7096  return 1;
7097  }
7098  }
7099  else if (index_p != NULL)
7100  *index_p += 1;
7101  }
7102  return 0;
7103 }
7104 
7105 /* Number of user-visible fields in record type TYPE. */
7106 
7107 static int
7109 {
7110  int n;
7111 
7112  n = 0;
7113  find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n);
7114  return n;
7115 }
7116 
7117 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7118  and search in it assuming it has (class) type TYPE.
7119  If found, return value, else return NULL.
7120 
7121  Searches recursively through wrapper fields (e.g., '_parent'). */
7122 
7123 static struct value *
7124 ada_search_struct_field (char *name, struct value *arg, int offset,
7125  struct type *type)
7126 {
7127  int i;
7128 
7129  type = ada_check_typedef (type);
7130  for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7131  {
7132  const char *t_field_name = TYPE_FIELD_NAME (type, i);
7133 
7134  if (t_field_name == NULL)
7135  continue;
7136 
7137  else if (field_name_match (t_field_name, name))
7138  return ada_value_primitive_field (arg, offset, i, type);
7139 
7140  else if (ada_is_wrapper_field (type, i))
7141  {
7142  struct value *v = /* Do not let indent join lines here. */
7143  ada_search_struct_field (name, arg,
7144  offset + TYPE_FIELD_BITPOS (type, i) / 8,
7145  TYPE_FIELD_TYPE (type, i));
7146 
7147  if (v != NULL)
7148  return v;
7149  }
7150 
7151  else if (ada_is_variant_part (type, i))
7152  {
7153  /* PNH: Do we ever get here? See find_struct_field. */
7154  int j;
7155  struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7156  i));
7157  int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7158 
7159  for (j = 0; j < TYPE_NFIELDS (field_type); j += 1)
7160  {
7161  struct value *v = ada_search_struct_field /* Force line
7162  break. */
7163  (name, arg,
7164  var_offset + TYPE_FIELD_BITPOS (field_type, j) / 8,
7165  TYPE_FIELD_TYPE (field_type, j));
7166 
7167  if (v != NULL)
7168  return v;
7169  }
7170  }
7171  }
7172  return NULL;
7173 }
7174 
7175 static struct value *ada_index_struct_field_1 (int *, struct value *,
7176  int, struct type *);
7177 
7178 
7179 /* Return field #INDEX in ARG, where the index is that returned by
7180  * find_struct_field through its INDEX_P argument. Adjust the address
7181  * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE.
7182  * If found, return value, else return NULL. */
7183 
7184 static struct value *
7185 ada_index_struct_field (int index, struct value *arg, int offset,
7186  struct type *type)
7187 {
7188  return ada_index_struct_field_1 (&index, arg, offset, type);
7189 }
7190 
7191 
7192 /* Auxiliary function for ada_index_struct_field. Like
7193  * ada_index_struct_field, but takes index from *INDEX_P and modifies
7194  * *INDEX_P. */
7195 
7196 static struct value *
7197 ada_index_struct_field_1 (int *index_p, struct value *arg, int offset,
7198  struct type *type)
7199 {
7200  int i;
7201  type = ada_check_typedef (type);
7202 
7203  for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7204  {
7205  if (TYPE_FIELD_NAME (type, i) == NULL)
7206  continue;
7207  else if (ada_is_wrapper_field (type, i))
7208  {
7209  struct value *v = /* Do not let indent join lines here. */
7210  ada_index_struct_field_1 (index_p, arg,
7211  offset + TYPE_FIELD_BITPOS (type, i) / 8,
7212  TYPE_FIELD_TYPE (type, i));
7213 
7214  if (v != NULL)
7215  return v;
7216  }
7217 
7218  else if (ada_is_variant_part (type, i))
7219  {
7220  /* PNH: Do we ever get here? See ada_search_struct_field,
7221  find_struct_field. */
7222  error (_("Cannot assign this kind of variant record"));
7223  }
7224  else if (*index_p == 0)
7225  return ada_value_primitive_field (arg, offset, i, type);
7226  else
7227  *index_p -= 1;
7228  }
7229  return NULL;
7230 }
7231 
7232 /* Given ARG, a value of type (pointer or reference to a)*
7233  structure/union, extract the component named NAME from the ultimate
7234  target structure/union and return it as a value with its
7235  appropriate type.
7236 
7237  The routine searches for NAME among all members of the structure itself
7238  and (recursively) among all members of any wrapper members
7239  (e.g., '_parent').
7240 
7241  If NO_ERR, then simply return NULL in case of error, rather than
7242  calling error. */
7243 
7244 struct value *
7245 ada_value_struct_elt (struct value *arg, char *name, int no_err)
7246 {
7247  struct type *t, *t1;
7248  struct value *v;
7249 
7250  v = NULL;
7251  t1 = t = ada_check_typedef (value_type (arg));
7252  if (TYPE_CODE (t) == TYPE_CODE_REF)
7253  {
7254  t1 = TYPE_TARGET_TYPE (t);
7255  if (t1 == NULL)
7256  goto BadValue;
7257  t1 = ada_check_typedef (t1);
7258  if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7259  {
7260  arg = coerce_ref (arg);
7261  t = t1;
7262  }
7263  }
7264 
7265  while (TYPE_CODE (t) == TYPE_CODE_PTR)
7266  {
7267  t1 = TYPE_TARGET_TYPE (t);
7268  if (t1 == NULL)
7269  goto BadValue;
7270  t1 = ada_check_typedef (t1);
7271  if (TYPE_CODE (t1) == TYPE_CODE_PTR)
7272  {
7273  arg = value_ind (arg);
7274  t = t1;
7275  }
7276  else
7277  break;
7278  }
7279 
7280  if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
7281  goto BadValue;
7282 
7283  if (t1 == t)
7284  v = ada_search_struct_field (name, arg, 0, t);
7285  else
7286  {
7287  int bit_offset, bit_size, byte_offset;
7288  struct type *field_type;
7289  CORE_ADDR address;
7290 
7291  if (TYPE_CODE (t) == TYPE_CODE_PTR)
7292  address = value_address (ada_value_ind (arg));
7293  else
7294  address = value_address (ada_coerce_ref (arg));
7295 
7296  t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
7297  if (find_struct_field (name, t1, 0,
7298  &field_type, &byte_offset, &bit_offset,
7299  &bit_size, NULL))
7300  {
7301  if (bit_size != 0)
7302  {
7303  if (TYPE_CODE (t) == TYPE_CODE_REF)
7304  arg = ada_coerce_ref (arg);
7305  else
7306  arg = ada_value_ind (arg);
7307  v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7308  bit_offset, bit_size,
7309  field_type);
7310  }
7311  else
7312  v = value_at_lazy (field_type, address + byte_offset);
7313  }
7314  }
7315 
7316  if (v != NULL || no_err)
7317  return v;
7318  else
7319  error (_("There is no member named %s."), name);
7320 
7321  BadValue:
7322  if (no_err)
7323  return NULL;
7324  else
7325  error (_("Attempt to extract a component of "
7326  "a value that is not a record."));
7327 }
7328 
7329 /* Given a type TYPE, look up the type of the component of type named NAME.
7330  If DISPP is non-null, add its byte displacement from the beginning of a
7331  structure (pointed to by a value) of type TYPE to *DISPP (does not
7332  work for packed fields).
7333 
7334  Matches any field whose name has NAME as a prefix, possibly
7335  followed by "___".
7336 
7337  TYPE can be either a struct or union. If REFOK, TYPE may also
7338  be a (pointer or reference)+ to a struct or union, and the
7339  ultimate target type will be searched.
7340 
7341  Looks recursively into variant clauses and parent types.
7342 
7343  If NOERR is nonzero, return NULL if NAME is not suitably defined or
7344  TYPE is not a type of the right kind. */
7345 
7346 static struct type *
7347 ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
7348  int noerr, int *dispp)
7349 {
7350  int i;
7351 
7352  if (name == NULL)
7353  goto BadName;
7354 
7355  if (refok && type != NULL)
7356  while (1)
7357  {
7358  type = ada_check_typedef (type);
7359  if (TYPE_CODE (type) != TYPE_CODE_PTR
7360  && TYPE_CODE (type) != TYPE_CODE_REF)
7361  break;
7362  type = TYPE_TARGET_TYPE (type);
7363  }
7364 
7365  if (type == NULL
7366  || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7367  && TYPE_CODE (type) != TYPE_CODE_UNION))
7368  {
7369  if (noerr)
7370  return NULL;
7371  else
7372  {
7375  if (type == NULL)
7376  error (_("Type (null) is not a structure or union type"));
7377  else
7378  {
7379  /* XXX: type_sprint */
7380  fprintf_unfiltered (gdb_stderr, _("Type "));
7381  type_print (type, "", gdb_stderr, -1);
7382  error (_(" is not a structure or union type"));
7383  }
7384  }
7385  }
7386 
7387  type = to_static_fixed_type (type);
7388 
7389  for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7390  {
7391  const char *t_field_name = TYPE_FIELD_NAME (type, i);
7392  struct type *t;
7393  int disp;
7394 
7395  if (t_field_name == NULL)
7396  continue;
7397 
7398  else if (field_name_match (t_field_name, name))
7399  {
7400  if (dispp != NULL)
7401  *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
7402  return TYPE_FIELD_TYPE (type, i);
7403  }
7404 
7405  else if (ada_is_wrapper_field (type, i))
7406  {
7407  disp = 0;
7408  t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7409  0, 1, &disp);
7410  if (t != NULL)
7411  {
7412  if (dispp != NULL)
7413  *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7414  return t;
7415  }
7416  }
7417 
7418  else if (ada_is_variant_part (type, i))
7419  {
7420  int j;
7421  struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type,
7422  i));
7423 
7424  for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7425  {
7426  /* FIXME pnh 2008/01/26: We check for a field that is
7427  NOT wrapped in a struct, since the compiler sometimes
7428  generates these for unchecked variant types. Revisit
7429  if the compiler changes this practice. */
7430  const char *v_field_name = TYPE_FIELD_NAME (field_type, j);
7431  disp = 0;
7432  if (v_field_name != NULL
7433  && field_name_match (v_field_name, name))
7434  t = TYPE_FIELD_TYPE (field_type, j);
7435  else
7437  j),
7438  name, 0, 1, &disp);
7439 
7440  if (t != NULL)
7441  {
7442  if (dispp != NULL)
7443  *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7444  return t;
7445  }
7446  }
7447  }
7448 
7449  }
7450 
7451 BadName:
7452  if (!noerr)
7453  {
7456  if (name == NULL)
7457  {
7458  /* XXX: type_sprint */
7459  fprintf_unfiltered (gdb_stderr, _("Type "));
7460  type_print (type, "", gdb_stderr, -1);
7461  error (_(" has no component named <null>"));
7462  }
7463  else
7464  {
7465  /* XXX: type_sprint */
7466  fprintf_unfiltered (gdb_stderr, _("Type "));
7467  type_print (type, "", gdb_stderr, -1);
7468  error (_(" has no component named %s"), name);
7469  }
7470  }
7471 
7472  return NULL;
7473 }
7474 
7475 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7476  within a value of type OUTER_TYPE, return true iff VAR_TYPE
7477  represents an unchecked union (that is, the variant part of a
7478  record that is named in an Unchecked_Union pragma). */
7479 
7480 static int
7481 is_unchecked_variant (struct type *var_type, struct type *outer_type)
7482 {
7483  char *discrim_name = ada_variant_discrim_name (var_type);
7484 
7485  return (ada_lookup_struct_elt_type (outer_type, discrim_name, 0, 1, NULL)
7486  == NULL);
7487 }
7488 
7489 
7490 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7491  within a value of type OUTER_TYPE that is stored in GDB at
7492  OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7493  numbering from 0) is applicable. Returns -1 if none are. */
7494 
7495 int
7496 ada_which_variant_applies (struct type *var_type, struct type *outer_type,
7497  const gdb_byte *outer_valaddr)
7498 {
7499  int others_clause;
7500  int i;
7501  char *discrim_name = ada_variant_discrim_name (var_type);
7502  struct value *outer;
7503  struct value *discrim;
7504  LONGEST discrim_val;
7505 
7506  /* Using plain value_from_contents_and_address here causes problems
7507  because we will end up trying to resolve a type that is currently
7508  being constructed. */
7509  outer = value_from_contents_and_address_unresolved (outer_type,
7510  outer_valaddr, 0);
7511  discrim = ada_value_struct_elt (outer, discrim_name, 1);
7512  if (discrim == NULL)
7513  return -1;
7514  discrim_val = value_as_long (discrim);
7515 
7516  others_clause = -1;
7517  for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7518  {
7519  if (ada_is_others_clause (var_type, i))
7520  others_clause = i;
7521  else if (ada_in_variant (discrim_val, var_type, i))
7522  return i;
7523  }
7524 
7525  return others_clause;
7526 }
7527 
7528 
7529 
7530  /* Dynamic-Sized Records */
7531 
7532 /* Strategy: The type ostensibly attached to a value with dynamic size
7533  (i.e., a size that is not statically recorded in the debugging
7534  data) does not accurately reflect the size or layout of the value.
7535  Our strategy is to convert these values to values with accurate,
7536  conventional types that are constructed on the fly. */
7537 
7538 /* There is a subtle and tricky problem here. In general, we cannot
7539  determine the size of dynamic records without its data. However,
7540  the 'struct value' data structure, which GDB uses to represent
7541  quantities in the inferior process (the target), requires the size
7542  of the type at the time of its allocation in order to reserve space
7543  for GDB's internal copy of the data. That's why the
7544  'to_fixed_xxx_type' routines take (target) addresses as parameters,
7545  rather than struct value*s.
7546 
7547  However, GDB's internal history variables ($1, $2, etc.) are
7548  struct value*s containing internal copies of the data that are not, in
7549  general, the same as the data at their corresponding addresses in
7550  the target. Fortunately, the types we give to these values are all
7551  conventional, fixed-size types (as per the strategy described
7552  above), so that we don't usually have to perform the
7553  'to_fixed_xxx_type' conversions to look at their values.
7554  Unfortunately, there is one exception: if one of the internal
7555  history variables is an array whose elements are unconstrained
7556  records, then we will need to create distinct fixed types for each
7557  element selected. */
7558 
7559 /* The upshot of all of this is that many routines take a (type, host
7560  address, target address) triple as arguments to represent a value.
7561  The host address, if non-null, is supposed to contain an internal
7562  copy of the relevant data; otherwise, the program is to consult the
7563  target at the target address. */
7564 
7565 /* Assuming that VAL0 represents a pointer value, the result of
7566  dereferencing it. Differs from value_ind in its treatment of
7567  dynamic-sized types. */
7568 
7569 struct value *
7570 ada_value_ind (struct value *val0)
7571 {
7572  struct value *val = value_ind (val0);
7573 
7574  if (ada_is_tagged_type (value_type (val), 0))
7575  val = ada_tag_value_at_base_address (val);
7576 
7577  return ada_to_fixed_value (val);
7578 }
7579 
7580 /* The value resulting from dereferencing any "reference to"
7581  qualifiers on VAL0. */
7582 
7583 static struct value *
7584 ada_coerce_ref (struct value *val0)
7585 {
7586  if (TYPE_CODE (value_type (val0)) == TYPE_CODE_REF)
7587  {
7588  struct value *val = val0;
7589 
7590  val = coerce_ref (val);
7591 
7592  if (ada_is_tagged_type (value_type (val), 0))
7593  val = ada_tag_value_at_base_address (val);
7594 
7595  return ada_to_fixed_value (val);
7596  }
7597  else
7598  return val0;
7599 }
7600 
7601 /* Return OFF rounded upward if necessary to a multiple of
7602  ALIGNMENT (a power of 2). */
7603 
7604 static unsigned int
7605 align_value (unsigned int off, unsigned int alignment)
7606 {
7607  return (off + alignment - 1) & ~(alignment - 1);
7608 }
7609 
7610 /* Return the bit alignment required for field #F of template type TYPE. */
7611 
7612 static unsigned int
7613 field_alignment (struct type *type, int f)
7614 {
7615  const char *name = TYPE_FIELD_NAME (type, f);
7616  int len;
7617  int align_offset;
7618 
7619  /* The field name should never be null, unless the debugging information
7620  is somehow malformed. In this case, we assume the field does not
7621  require any alignment. */
7622  if (name == NULL)
7623  return 1;
7624 
7625  len = strlen (name);
7626 
7627  if (!isdigit (name[len - 1]))
7628  return 1;
7629 
7630  if (isdigit (name[len - 2]))
7631  align_offset = len - 2;
7632  else
7633  align_offset = len - 1;
7634 
7635  if (align_offset < 7 || !startswith (name + align_offset - 6, "___XV"))
7636  return TARGET_CHAR_BIT;
7637 
7638  return atoi (name + align_offset) * TARGET_CHAR_BIT;
7639 }
7640 
7641 /* Find a typedef or tag symbol named NAME. Ignores ambiguity. */
7642 
7643 static struct symbol *
7645 {
7646  struct symbol *sym;
7647 
7648  sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7649  if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7650  return sym;
7651 
7652  sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7653  return sym;
7654 }
7655 
7656 /* Find a type named NAME. Ignores ambiguity. This routine will look
7657  solely for types defined by debug info, it will not search the GDB
7658  primitive types. */
7659 
7660 static struct type *
7662 {
7663  struct symbol *sym = ada_find_any_type_symbol (name);
7664 
7665  if (sym != NULL)
7666  return SYMBOL_TYPE (sym);
7667 
7668  return NULL;
7669 }
7670 
7671 /* Given NAME_SYM and an associated BLOCK, find a "renaming" symbol
7672  associated with NAME_SYM's name. NAME_SYM may itself be a renaming
7673  symbol, in which case it is returned. Otherwise, this looks for
7674  symbols whose name is that of NAME_SYM suffixed with "___XR".
7675  Return symbol if found, and NULL otherwise. */
7676 
7677 struct symbol *
7678 ada_find_renaming_symbol (struct symbol *name_sym, const struct block *block)
7679 {
7680  const char *name = SYMBOL_LINKAGE_NAME (name_sym);
7681  struct symbol *sym;
7682 
7683  if (strstr (name, "___XR") != NULL)
7684  return name_sym;
7685 
7686  sym = find_old_style_renaming_symbol (name, block);
7687 
7688  if (sym != NULL)
7689  return sym;
7690 
7691  /* Not right yet. FIXME pnh 7/20/2007. */
7692  sym = ada_find_any_type_symbol (name);
7693  if (sym != NULL && strstr (SYMBOL_LINKAGE_NAME (sym), "___XR") != NULL)
7694  return sym;
7695  else
7696  return NULL;
7697 }
7698 
7699 static struct symbol *
7700 find_old_style_renaming_symbol (const char *name, const struct block *block)
7701 {
7702  const struct symbol *function_sym = block_linkage_function (block);
7703  char *rename;
7704 
7705  if (function_sym != NULL)
7706  {
7707  /* If the symbol is defined inside a function, NAME is not fully
7708  qualified. This means we need to prepend the function name
7709  as well as adding the ``___XR'' suffix to build the name of
7710  the associated renaming symbol. */
7711  const char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
7712  /* Function names sometimes contain suffixes used
7713  for instance to qualify nested subprograms. When building
7714  the XR type name, we need to make sure that this suffix is
7715  not included. So do not include any suffix in the function
7716  name length below. */
7717  int function_name_len = ada_name_prefix_len (function_name);
7718  const int rename_len = function_name_len + 2 /* "__" */
7719  + strlen (name) + 6 /* "___XR\0" */ ;
7720 
7721  /* Strip the suffix if necessary. */
7722  ada_remove_trailing_digits (function_name, &function_name_len);
7723  ada_remove_po_subprogram_suffix (function_name, &function_name_len);
7724  ada_remove_Xbn_suffix (function_name, &function_name_len);
7725 
7726  /* Library-level functions are a special case, as GNAT adds
7727  a ``_ada_'' prefix to the function name to avoid namespace
7728  pollution. However, the renaming symbols themselves do not
7729  have this prefix, so we need to skip this prefix if present. */
7730  if (function_name_len > 5 /* "_ada_" */
7731  && strstr (function_name, "_ada_") == function_name)
7732  {
7733  function_name += 5;
7734  function_name_len -= 5;
7735  }
7736 
7737  rename = (char *) alloca (rename_len * sizeof (char));
7738  strncpy (rename, function_name, function_name_len);
7739  xsnprintf (rename + function_name_len, rename_len - function_name_len,
7740  "__%s___XR", name);
7741  }
7742  else
7743  {
7744  const int rename_len = strlen (name) + 6;
7745 
7746  rename = (char *) alloca (rename_len * sizeof (char));
7747  xsnprintf (rename, rename_len * sizeof (char), "%s___XR", name);
7748  }
7749 
7750  return ada_find_any_type_symbol (rename);
7751 }
7752 
7753 /* Because of GNAT encoding conventions, several GDB symbols may match a
7754  given type name. If the type denoted by TYPE0 is to be preferred to
7755  that of TYPE1 for purposes of type printing, return non-zero;
7756  otherwise return 0. */
7757 
7758 int
7759 ada_prefer_type (struct type *type0, struct type *type1)
7760 {
7761  if (type1 == NULL)
7762  return 1;
7763  else if (type0 == NULL)
7764  return 0;
7765  else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7766  return 1;
7767  else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7768  return 0;
7769  else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7770  return 1;
7771  else if (ada_is_constrained_packed_array_type (type0))
7772  return 1;
7773  else if (ada_is_array_descriptor_type (type0)
7774  && !ada_is_array_descriptor_type (type1))
7775  return 1;
7776  else
7777  {
7778  const char *type0_name = type_name_no_tag (type0);
7779  const char *type1_name = type_name_no_tag (type1);
7780 
7781  if (type0_name != NULL && strstr (type0_name, "___XR") != NULL
7782  && (type1_name == NULL || strstr (type1_name, "___XR") == NULL))
7783  return 1;
7784  }
7785  return 0;
7786 }
7787 
7788 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7789  null, its TYPE_TAG_NAME. Null if TYPE is null. */
7790 
7791 const char *
7793 {
7794  if (type == NULL)
7795  return NULL;
7796  else if (TYPE_NAME (type) != NULL)
7797  return TYPE_NAME (type);
7798  else
7799  return TYPE_TAG_NAME (type);
7800 }
7801 
7802 /* Search the list of "descriptive" types associated to TYPE for a type
7803  whose name is NAME. */
7804 
7805 static struct type *
7807 {
7808  struct type *result, *tmp;
7809 
7810  if (ada_ignore_descriptive_types_p)
7811  return NULL;
7812 
7813  /* If there no descriptive-type info, then there is no parallel type
7814  to be found. */
7815  if (!HAVE_GNAT_AUX_INFO (type))
7816  return NULL;
7817 
7818  result = TYPE_DESCRIPTIVE_TYPE (type);
7819  while (result != NULL)
7820  {
7821  const char *result_name = ada_type_name (result);
7822 
7823  if (result_name == NULL)
7824  {
7825  warning (_("unexpected null name on descriptive type"));
7826  return NULL;
7827  }
7828 
7829  /* If the names match, stop. */
7830  if (strcmp (result_name, name) == 0)
7831  break;
7832 
7833  /* Otherwise, look at the next item on the list, if any. */
7834  if (HAVE_GNAT_AUX_INFO (result))
7835  tmp = TYPE_DESCRIPTIVE_TYPE (result);
7836  else
7837  tmp = NULL;
7838 
7839  /* If not found either, try after having resolved the typedef. */
7840  if (tmp != NULL)
7841  result = tmp;
7842  else
7843  {
7844  CHECK_TYPEDEF (result);
7845  if (HAVE_GNAT_AUX_INFO (result))
7846  result = TYPE_DESCRIPTIVE_TYPE (result);
7847  else
7848  result = NULL;
7849  }
7850  }
7851 
7852  /* If we didn't find a match, see whether this is a packed array. With
7853  older compilers, the descriptive type information is either absent or
7854  irrelevant when it comes to packed arrays so the above lookup fails.
7855  Fall back to using a parallel lookup by name in this case. */
7856  if (result == NULL && ada_is_constrained_packed_array_type (type))
7857  return ada_find_any_type (name);
7858 
7859  return result;
7860 }
7861 
7862 /* Find a parallel type to TYPE with the specified NAME, using the
7863  descriptive type taken from the debugging information, if available,
7864  and otherwise using the (slower) name-based method. */
7865 
7866 static struct type *
7868 {
7869  struct type *result = NULL;
7870 
7871  if (HAVE_GNAT_AUX_INFO (type))
7872  result = find_parallel_type_by_descriptive_type (type, name);
7873  else
7874  result = ada_find_any_type (name);
7875 
7876  return result;
7877 }
7878 
7879 /* Same as above, but specify the name of the parallel type by appending
7880  SUFFIX to the name of TYPE. */
7881 
7882 struct type *
7883 ada_find_parallel_type (struct type *type, const char *suffix)
7884 {
7885  char *name;
7886  const char *type_name = ada_type_name (type);
7887  int len;
7888 
7889  if (type_name == NULL)
7890  return NULL;
7891 
7892  len = strlen (type_name);
7893 
7894  name = (char *) alloca (len + strlen (suffix) + 1);
7895 
7896  strcpy (name, type_name);
7897  strcpy (name + len, suffix);
7898 
7899  return ada_find_parallel_type_with_name (type, name);
7900 }
7901 
7902 /* If TYPE is a variable-size record type, return the corresponding template
7903  type describing its fields. Otherwise, return NULL. */
7904 
7905 static struct type *
7907 {
7908  type = ada_check_typedef (type);
7909 
7910  if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
7911  || ada_type_name (type) == NULL)
7912  return NULL;
7913  else
7914  {
7915  int len = strlen (ada_type_name (type));
7916 
7917  if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7918  return type;
7919  else
7920  return ada_find_parallel_type (type, "___XVE");
7921  }
7922 }
7923 
7924 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7925  non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7926 
7927 static int
7928 is_dynamic_field (struct type *templ_type, int field_num)
7929 {
7930  const char *name = TYPE_FIELD_NAME (templ_type, field_num);
7931 
7932  return name != NULL
7933  && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7934  && strstr (name, "___XVL") != NULL;
7935 }
7936 
7937 /* The index of the variant field of TYPE, or -1 if TYPE does not
7938  represent a variant record type. */
7939 
7940 static int
7942 {
7943  int f;
7944 
7945  if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7946  return -1;
7947 
7948  for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7949  {
7950  if (ada_is_variant_part (type, f))
7951  return f;
7952  }
7953  return -1;
7954 }
7955 
7956 /* A record type with no fields. */
7957 
7958 static struct type *
7959 empty_record (struct type *templ)
7960 {
7961  struct type *type = alloc_type_copy (templ);
7962 
7963  TYPE_CODE (type) = TYPE_CODE_STRUCT;
7964  TYPE_NFIELDS (type) = 0;
7965  TYPE_FIELDS (type) = NULL;
7966  INIT_CPLUS_SPECIFIC (type);
7967  TYPE_NAME (type) = "<empty>";
7968  TYPE_TAG_NAME (type) = NULL;
7969  TYPE_LENGTH (type) = 0;
7970  return type;
7971 }
7972 
7973 /* An ordinary record type (with fixed-length fields) that describes
7974  the value of type TYPE at VALADDR or ADDRESS (see comments at
7975  the beginning of this section) VAL according to GNAT conventions.
7976  DVAL0 should describe the (portion of a) record that contains any
7977  necessary discriminants. It should be NULL if value_type (VAL) is
7978  an outer-level type (i.e., as opposed to a branch of a variant.) A
7979  variant field (unless unchecked) is replaced by a particular branch
7980  of the variant.
7981 
7982  If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7983  length are not statically known are discarded. As a consequence,
7984  VALADDR, ADDRESS and DVAL0 are ignored.
7985 
7986  NOTE: Limitations: For now, we assume that dynamic fields and
7987  variants occupy whole numbers of bytes. However, they need not be
7988  byte-aligned. */
7989 
7990 struct type *
7992  const gdb_byte *valaddr,
7993  CORE_ADDR address, struct value *dval0,
7994  int keep_dynamic_fields)
7995 {
7996  struct value *mark = value_mark ();
7997  struct value *dval;
7998  struct type *rtype;
7999  int nfields, bit_len;
8000  int variant_field;
8001  long off;
8002  int fld_bit_len;
8003  int f;
8004 
8005  /* Compute the number of fields in this record type that are going
8006  to be processed: unless keep_dynamic_fields, this includes only
8007  fields whose position and length are static will be processed. */
8008  if (keep_dynamic_fields)
8009  nfields = TYPE_NFIELDS (type);
8010  else
8011  {
8012  nfields = 0;
8013  while (nfields < TYPE_NFIELDS (type)
8014  && !ada_is_variant_part (type, nfields)
8015  && !is_dynamic_field (type, nfields))
8016  nfields++;
8017  }
8018 
8019  rtype = alloc_type_copy (type);
8020  TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8021  INIT_CPLUS_SPECIFIC (rtype);
8022  TYPE_NFIELDS (rtype) = nfields;
8023  TYPE_FIELDS (rtype) = (struct field *)
8024  TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8025  memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
8026  TYPE_NAME (rtype) = ada_type_name (type);
8027  TYPE_TAG_NAME (rtype) = NULL;
8028  TYPE_FIXED_INSTANCE (rtype) = 1;
8029 
8030  off = 0;
8031  bit_len = 0;
8032  variant_field = -1;
8033 
8034  for (f = 0; f < nfields; f += 1)
8035  {
8036  off = align_value (off, field_alignment (type, f))
8037  + TYPE_FIELD_BITPOS (type, f);
8038  SET_FIELD_BITPOS (TYPE_FIELD (rtype, f), off);
8039  TYPE_FIELD_BITSIZE (rtype, f) = 0;
8040 
8041  if (ada_is_variant_part (type, f))
8042  {
8043  variant_field = f;
8044  fld_bit_len = 0;
8045  }
8046  else if (is_dynamic_field (type, f))
8047  {
8048  const gdb_byte *field_valaddr = valaddr;
8049  CORE_ADDR field_address = address;
8050  struct type *field_type =
8051  TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f));
8052 
8053  if (dval0 == NULL)
8054  {
8055  /* rtype's length is computed based on the run-time
8056  value of discriminants. If the discriminants are not
8057  initialized, the type size may be completely bogus and
8058  GDB may fail to allocate a value for it. So check the
8059  size first before creating the value. */
8060  ada_ensure_varsize_limit (rtype);
8061  /* Using plain value_from_contents_and_address here
8062  causes problems because we will end up trying to
8063  resolve a type that is currently being
8064  constructed. */
8066  valaddr,
8067  address);
8068  rtype = value_type (dval);
8069  }
8070  else
8071  dval = dval0;
8072 
8073  /* If the type referenced by this field is an aligner type, we need
8074  to unwrap that aligner type, because its size might not be set.
8075  Keeping the aligner type would cause us to compute the wrong
8076  size for this field, impacting the offset of the all the fields
8077  that follow this one. */
8078  if (ada_is_aligner_type (field_type))
8079  {
8080  long field_offset = TYPE_FIELD_BITPOS (field_type, f);
8081 
8082  field_valaddr = cond_offset_host (field_valaddr, field_offset);
8083  field_address = cond_offset_target (field_address, field_offset);
8084  field_type = ada_aligned_type (field_type);
8085  }
8086 
8087  field_valaddr = cond_offset_host (field_valaddr,
8088  off / TARGET_CHAR_BIT);
8089  field_address = cond_offset_target (field_address,
8090  off / TARGET_CHAR_BIT);
8091 
8092  /* Get the fixed type of the field. Note that, in this case,
8093  we do not want to get the real type out of the tag: if
8094  the current field is the parent part of a tagged record,
8095  we will get the tag of the object. Clearly wrong: the real
8096  type of the parent is not the real type of the child. We
8097  would end up in an infinite loop. */
8098  field_type = ada_get_base_type (field_type);
8099  field_type = ada_to_fixed_type (field_type, field_valaddr,
8100  field_address, dval, 0);
8101  /* If the field size is already larger than the maximum
8102  object size, then the record itself will necessarily
8103  be larger than the maximum object size. We need to make
8104  this check now, because the size might be so ridiculously
8105  large (due to an uninitialized variable in the inferior)
8106  that it would cause an overflow when adding it to the
8107  record size. */
8108  ada_ensure_varsize_limit (field_type);
8109 
8110  TYPE_FIELD_TYPE (rtype, f) = field_type;
8111  TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8112  /* The multiplication can potentially overflow. But because
8113  the field length has been size-checked just above, and
8114  assuming that the maximum size is a reasonable value,
8115  an overflow should not happen in practice. So rather than
8116  adding overflow recovery code to this already complex code,
8117  we just assume that it's not going to happen. */
8118  fld_bit_len =
8120  }
8121  else
8122  {
8123  /* Note: If this field's type is a typedef, it is important
8124  to preserve the typedef layer.
8125 
8126  Otherwise, we might be transforming a typedef to a fat
8127  pointer (encoding a pointer to an unconstrained array),
8128  into a basic fat pointer (encoding an unconstrained
8129  array). As both types are implemented using the same
8130  structure, the typedef is the only clue which allows us
8131  to distinguish between the two options. Stripping it
8132  would prevent us from printing this field appropriately. */
8133  TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
8134  TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
8135  if (TYPE_FIELD_BITSIZE (type, f) > 0)
8136  fld_bit_len =
8137  TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
8138  else
8139  {
8140  struct type *field_type = TYPE_FIELD_TYPE (type, f);
8141 
8142  /* We need to be careful of typedefs when computing
8143  the length of our field. If this is a typedef,
8144  get the length of the target type, not the length
8145  of the typedef. */
8146  if (TYPE_CODE (field_type) == TYPE_CODE_TYPEDEF)
8147  field_type = ada_typedef_target_type (field_type);
8148 
8149  fld_bit_len =
8151  }
8152  }
8153  if (off + fld_bit_len > bit_len)
8154  bit_len = off + fld_bit_len;
8155  off += fld_bit_len;
8156  TYPE_LENGTH (rtype) =
8158  }
8159 
8160  /* We handle the variant part, if any, at the end because of certain
8161  odd cases in which it is re-ordered so as NOT to be the last field of
8162  the record. This can happen in the presence of representation
8163  clauses. */
8164  if (variant_field >= 0)
8165  {
8166  struct type *branch_type;
8167 
8168  off = TYPE_FIELD_BITPOS (rtype, variant_field);
8169 
8170  if (dval0 == NULL)
8171  {
8172  /* Using plain value_from_contents_and_address here causes
8173  problems because we will end up trying to resolve a type
8174  that is currently being constructed. */
8175  dval = value_from_contents_and_address_unresolved (rtype, valaddr,
8176  address);
8177  rtype = value_type (dval);
8178  }
8179  else
8180  dval = dval0;
8181 
8182  branch_type =
8184  (TYPE_FIELD_TYPE (type, variant_field),
8185  cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
8186  cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
8187  if (branch_type == NULL)
8188  {
8189  for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
8190  TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8191  TYPE_NFIELDS (rtype) -= 1;
8192  }
8193  else
8194  {
8195  TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8196  TYPE_FIELD_NAME (rtype, variant_field) = "S";
8197  fld_bit_len =
8198  TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
8200  if (off + fld_bit_len > bit_len)
8201  bit_len = off + fld_bit_len;
8202  TYPE_LENGTH (rtype) =
8204  }
8205  }
8206 
8207  /* According to exp_dbug.ads, the size of TYPE for variable-size records
8208  should contain the alignment of that record, which should be a strictly
8209  positive value. If null or negative, then something is wrong, most
8210  probably in the debug info. In that case, we don't round up the size
8211  of the resulting type. If this record is not part of another structure,
8212  the current RTYPE length might be good enough for our purposes. */
8213  if (TYPE_LENGTH (type) <= 0)
8214  {
8215  if (TYPE_NAME (rtype))
8216  warning (_("Invalid type size for `%s' detected: %d."),
8217  TYPE_NAME (rtype), TYPE_LENGTH (type));
8218  else
8219  warning (_("Invalid type size for <unnamed> detected: %d."),
8220  TYPE_LENGTH (type));
8221  }
8222  else
8223  {
8224  TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype),
8225  TYPE_LENGTH (type));
8226  }
8227 
8228  value_free_to_mark (mark);
8229  if (TYPE_LENGTH (rtype) > varsize_limit)
8230  error (_("record type with dynamic size is larger than varsize-limit"));
8231  return rtype;
8232 }
8233 
8234 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
8235  of 1. */
8236 
8237 static struct type *
8239  CORE_ADDR address, struct value *dval0)
8240 {
8241  return ada_template_to_fixed_record_type_1 (type, valaddr,
8242  address, dval0, 1);
8243 }
8244 
8245 /* An ordinary record type in which ___XVL-convention fields and
8246  ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
8247  static approximations, containing all possible fields. Uses
8248  no runtime values. Useless for use in values, but that's OK,
8249  since the results are used only for type determinations. Works on both
8250  structs and unions. Representation note: to save space, we memorize
8251  the result of this function in the TYPE_TARGET_TYPE of the
8252  template type. */
8253 
8254 static struct type *
8256 {
8257  struct type *type;
8258  int nfields;
8259  int f;
8260 
8261  /* No need no do anything if the input type is already fixed. */
8262  if (TYPE_FIXED_INSTANCE (type0))
8263  return type0;
8264 
8265  /* Likewise if we already have computed the static approximation. */
8266  if (TYPE_TARGET_TYPE (type0) != NULL)
8267  return TYPE_TARGET_TYPE (type0);
8268 
8269  /* Don't clone TYPE0 until we are sure we are going to need a copy. */
8270  type = type0;
8271  nfields = TYPE_NFIELDS (type0);
8272 
8273  /* Whether or not we cloned TYPE0, cache the result so that we don't do
8274  recompute all over next time. */
8275  TYPE_TARGET_TYPE (type0) = type;
8276 
8277  for (f = 0; f < nfields; f += 1)
8278  {
8279  struct type *field_type = TYPE_FIELD_TYPE (type0, f);
8280  struct type *new_type;
8281 
8282  if (is_dynamic_field (type0, f))
8283  {
8284  field_type = ada_check_typedef (field_type);
8285  new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
8286  }
8287  else
8288  new_type = static_unwrap_type (field_type);
8289 
8290  if (new_type != field_type)
8291  {
8292  /* Clone TYPE0 only the first time we get a new field type. */
8293  if (type == type0)
8294  {
8295  TYPE_TARGET_TYPE (type0) = type = alloc_type_copy (type0);
8296  TYPE_CODE (type) = TYPE_CODE (type0);
8297  INIT_CPLUS_SPECIFIC (type);
8298  TYPE_NFIELDS (type) = nfields;
8299  TYPE_FIELDS (type) = (struct field *)
8300  TYPE_ALLOC (type, nfields * sizeof (struct field));
8301  memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
8302  sizeof (struct field) * nfields);
8303  TYPE_NAME (type) = ada_type_name (type0);
8304  TYPE_TAG_NAME (type) = NULL;
8305  TYPE_FIXED_INSTANCE (type) = 1;
8306  TYPE_LENGTH (type) = 0;
8307  }
8308  TYPE_FIELD_TYPE (type, f) = new_type;
8309  TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
8310  }
8311  }
8312 
8313  return type;
8314 }
8315 
8316 /* Given an object of type TYPE whose contents are at VALADDR and
8317  whose address in memory is ADDRESS, returns a revision of TYPE,
8318  which should be a non-dynamic-sized record, in which the variant
8319  part, if any, is replaced with the appropriate branch. Looks
8320  for discriminant values in DVAL0, which can be NULL if the record
8321  contains the necessary discriminant values. */
8322 
8323 static struct type *
8325  CORE_ADDR address, struct value *dval0)
8326 {
8327  struct value *mark = value_mark ();
8328  struct value *dval;
8329  struct type *rtype;
8330  struct type *branch_type;
8331  int nfields = TYPE_NFIELDS (type);
8332  int variant_field = variant_field_index (type);
8333 
8334  if (variant_field == -1)
8335  return type;
8336 
8337  if (dval0 == NULL)
8338  {
8339  dval = value_from_contents_and_address (type, valaddr, address);
8340  type = value_type (dval);
8341  }
8342  else
8343  dval = dval0;
8344 
8345  rtype = alloc_type_copy (type);
8346  TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
8347  INIT_CPLUS_SPECIFIC (rtype);
8348  TYPE_NFIELDS (rtype) = nfields;
8349  TYPE_FIELDS (rtype) =
8350  (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
8351  memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
8352  sizeof (struct field) * nfields);
8353  TYPE_NAME (rtype) = ada_type_name (type);
8354  TYPE_TAG_NAME (rtype) = NULL;
8355  TYPE_FIXED_INSTANCE (rtype) = 1;
8356  TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
8357 
8358  branch_type = to_fixed_variant_branch_type
8359  (TYPE_FIELD_TYPE (type, variant_field),
8360  cond_offset_host (valaddr,
8361  TYPE_FIELD_BITPOS (type, variant_field)
8362  / TARGET_CHAR_BIT),
8363  cond_offset_target (address,
8364  TYPE_FIELD_BITPOS (type, variant_field)
8365  / TARGET_CHAR_BIT), dval);
8366  if (branch_type == NULL)
8367  {
8368  int f;
8369 
8370  for (f = variant_field + 1; f < nfields; f += 1)
8371  TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
8372  TYPE_NFIELDS (rtype) -= 1;
8373  }
8374  else
8375  {
8376  TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
8377  TYPE_FIELD_NAME (rtype, variant_field) = "S";
8378  TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
8379  TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
8380  }
8381  TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
8382 
8383  value_free_to_mark (mark);
8384  return rtype;
8385 }
8386 
8387 /* An ordinary record type (with fixed-length fields) that describes
8388  the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
8389  beginning of this section]. Any necessary discriminants' values
8390  should be in DVAL, a record value; it may be NULL if the object
8391  at ADDR itself contains any necessary discriminant values.
8392  Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
8393  values from the record are needed. Except in the case that DVAL,
8394  VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
8395  unchecked) is replaced by a particular branch of the variant.
8396 
8397  NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
8398  is questionable and may be removed. It can arise during the
8399  processing of an unconstrained-array-of-record type where all the
8400  variant branches have exactly the same size. This is because in
8401  such cases, the compiler does not bother to use the XVS convention
8402  when encoding the record. I am currently dubious of this
8403  shortcut and suspect the compiler should be altered. FIXME. */
8404 
8405 static struct type *
8406 to_fixed_record_type (struct type *type0, const gdb_byte *valaddr,
8407  CORE_ADDR address, struct value *dval)
8408 {
8409  struct type *templ_type;
8410 
8411  if (TYPE_FIXED_INSTANCE (type0))
8412  return type0;
8413 
8414  templ_type = dynamic_template_type (type0);
8415 
8416  if (templ_type != NULL)
8417  return template_to_fixed_record_type (templ_type, valaddr, address, dval);
8418  else if (variant_field_index (type0) >= 0)
8419  {
8420  if (dval == NULL && valaddr == NULL && address == 0)
8421  return type0;
8422  return to_record_with_fixed_variant_part (type0, valaddr, address,
8423  dval);
8424  }
8425  else
8426  {
8427  TYPE_FIXED_INSTANCE (type0) = 1;
8428  return type0;
8429  }
8430 
8431 }
8432 
8433 /* An ordinary record type (with fixed-length fields) that describes
8434  the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
8435  union type. Any necessary discriminants' values should be in DVAL,
8436  a record value. That is, this routine selects the appropriate
8437  branch of the union at ADDR according to the discriminant value
8438  indicated in the union's type name. Returns VAR_TYPE0 itself if
8439  it represents a variant subject to a pragma Unchecked_Union. */
8440 
8441 static struct type *
8442 to_fixed_variant_branch_type (struct type *var_type0, const gdb_byte *valaddr,
8443  CORE_ADDR address, struct value *dval)
8444 {
8445  int which;
8446  struct type *templ_type;
8447  struct type *var_type;
8448 
8449  if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
8450  var_type = TYPE_TARGET_TYPE (var_type0);
8451  else
8452  var_type = var_type0;
8453 
8454  templ_type = ada_find_parallel_type (var_type, "___XVU");
8455 
8456  if (templ_type != NULL)
8457  var_type = templ_type;
8458 
8459  if (is_unchecked_variant (var_type, value_type (dval)))
8460  return var_type0;
8461  which =
8462  ada_which_variant_applies (var_type,
8463  value_type (dval), value_contents (dval));
8464 
8465  if (which < 0)
8466  return empty_record (var_type);
8467  else if (is_dynamic_field (var_type, which))
8468  return to_fixed_record_type
8469  (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
8470  valaddr, address, dval);
8471  else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
8472  return
8474  (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
8475  else
8476  return TYPE_FIELD_TYPE (var_type, which);
8477 }
8478 
8479 /* Assuming RANGE_TYPE is a TYPE_CODE_RANGE, return nonzero if
8480  ENCODING_TYPE, a type following the GNAT conventions for discrete
8481  type encodings, only carries redundant information. */
8482 
8483 static int
8485  struct type *encoding_type)
8486 {
8487  struct type *fixed_range_type;
8488  char *bounds_str;
8489  int n;
8490  LONGEST lo, hi;
8491 
8492  gdb_assert (TYPE_CODE (range_type) == TYPE_CODE_RANGE);
8493 
8494  if (TYPE_CODE (get_base_type (range_type))
8495  != TYPE_CODE (get_base_type (encoding_type)))
8496  {
8497  /* The compiler probably used a simple base type to describe
8498  the range type instead of the range's actual base type,
8499  expecting us to get the real base type from the encoding
8500  anyway. In this situation, the encoding cannot be ignored
8501  as redundant. */
8502  return 0;
8503  }
8504 
8505  if (is_dynamic_type (range_type))
8506  return 0;
8507 
8508  if (TYPE_NAME (encoding_type) == NULL)
8509  return 0;
8510 
8511  bounds_str = strstr (TYPE_NAME (encoding_type), "___XDLU_");
8512  if (bounds_str == NULL)
8513  return 0;
8514 
8515  n = 8; /* Skip "___XDLU_". */
8516  if (!ada_scan_number (bounds_str, n, &lo, &n))
8517  return 0;
8518  if (TYPE_LOW_BOUND (range_type) != lo)
8519  return 0;
8520 
8521  n += 2; /* Skip the "__" separator between the two bounds. */
8522  if (!ada_scan_number (bounds_str, n, &hi, &n))
8523  return 0;
8524  if (TYPE_HIGH_BOUND (range_type) != hi)
8525  return 0;
8526 
8527  return 1;
8528 }
8529 
8530 /* Given the array type ARRAY_TYPE, return nonzero if DESC_TYPE,
8531  a type following the GNAT encoding for describing array type
8532  indices, only carries redundant information. */
8533 
8534 static int
8536  struct type *desc_type)
8537 {
8538  struct type *this_layer = check_typedef (array_type);
8539  int i;
8540 
8541  for (i = 0; i < TYPE_NFIELDS (desc_type); i++)
8542  {
8544  TYPE_FIELD_TYPE (desc_type, i)))
8545  return 0;
8546  this_layer = check_typedef (TYPE_TARGET_TYPE (this_layer));
8547  }
8548 
8549  return 1;
8550 }
8551 
8552 /* Assuming that TYPE0 is an array type describing the type of a value
8553  at ADDR, and that DVAL describes a record containing any
8554  discriminants used in TYPE0, returns a type for the value that
8555  contains no dynamic components (that is, no components whose sizes
8556  are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8557  true, gives an error message if the resulting type's size is over
8558  varsize_limit. */
8559 
8560 static struct type *
8561 to_fixed_array_type (struct type *type0, struct value *dval,
8562  int ignore_too_big)
8563 {
8564  struct type *index_type_desc;
8565  struct type *result;
8566  int constrained_packed_array_p;
8567  static const char *xa_suffix = "___XA";
8568 
8569  type0 = ada_check_typedef (type0);
8570  if (TYPE_FIXED_INSTANCE (type0))
8571  return type0;
8572 
8573  constrained_packed_array_p = ada_is_constrained_packed_array_type (type0);
8574  if (constrained_packed_array_p)
8575  type0 = decode_constrained_packed_array_type (type0);
8576 
8577  index_type_desc = ada_find_parallel_type (type0, xa_suffix);
8578 
8579  /* As mentioned in exp_dbug.ads, for non bit-packed arrays an
8580  encoding suffixed with 'P' may still be generated. If so,
8581  it should be used to find the XA type. */
8582 
8583  if (index_type_desc == NULL)
8584  {
8585  const char *type_name = ada_type_name (type0);
8586 
8587  if (type_name != NULL)
8588  {
8589  const int len = strlen (type_name);
8590  char *name = (char *) alloca (len + strlen (xa_suffix));
8591 
8592  if (type_name[len - 1] == 'P')
8593  {
8594  strcpy (name, type_name);
8595  strcpy (name + len - 1, xa_suffix);
8596  index_type_desc = ada_find_parallel_type_with_name (type0, name);
8597  }
8598  }
8599  }
8600 
8601  ada_fixup_array_indexes_type (index_type_desc);
8602  if (index_type_desc != NULL
8603  && ada_is_redundant_index_type_desc (type0, index_type_desc))
8604  {
8605  /* Ignore this ___XA parallel type, as it does not bring any
8606  useful information. This allows us to avoid creating fixed
8607  versions of the array's index types, which would be identical
8608  to the original ones. This, in turn, can also help avoid
8609  the creation of fixed versions of the array itself. */
8610  index_type_desc = NULL;
8611  }
8612 
8613  if (index_type_desc == NULL)
8614  {
8615  struct type *elt_type0 = ada_check_typedef (TYPE_TARGET_TYPE (type0));
8616 
8617  /* NOTE: elt_type---the fixed version of elt_type0---should never
8618  depend on the contents of the array in properly constructed
8619  debugging data. */
8620  /* Create a fixed version of the array element type.
8621  We're not providing the address of an element here,
8622  and thus the actual object value cannot be inspected to do
8623  the conversion. This should not be a problem, since arrays of
8624  unconstrained objects are not allowed. In particular, all
8625  the elements of an array of a tagged type should all be of
8626  the same type specified in the debugging info. No need to
8627  consult the object tag. */
8628  struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval, 1);
8629 
8630  /* Make sure we always create a new array type when dealing with
8631  packed array types, since we're going to fix-up the array
8632  type length and element bitsize a little further down. */
8633  if (elt_type0 == elt_type && !constrained_packed_array_p)
8634  result = type0;
8635  else
8636  result = create_array_type (alloc_type_copy (type0),
8637  elt_type, TYPE_INDEX_TYPE (type0));
8638  }
8639  else
8640  {
8641  int i;
8642  struct type *elt_type0;
8643 
8644  elt_type0 = type0;
8645  for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
8646  elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8647 
8648  /* NOTE: result---the fixed version of elt_type0---should never
8649  depend on the contents of the array in properly constructed
8650  debugging data. */
8651  /* Create a fixed version of the array element type.
8652  We're not providing the address of an element here,
8653  and thus the actual object value cannot be inspected to do
8654  the conversion. This should not be a problem, since arrays of
8655  unconstrained objects are not allowed. In particular, all
8656  the elements of an array of a tagged type should all be of
8657  the same type specified in the debugging info. No need to
8658  consult the object tag. */
8659  result =
8660  ada_to_fixed_type (ada_check_typedef (elt_type0), 0, 0, dval, 1);
8661 
8662  elt_type0 = type0;
8663  for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
8664  {
8665  struct type *range_type =
8666  to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, i), dval);
8667 
8668  result = create_array_type (alloc_type_copy (elt_type0),
8669  result, range_type);
8670  elt_type0 = TYPE_TARGET_TYPE (elt_type0);
8671  }
8672  if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
8673  error (_("array type with dynamic size is larger than varsize-limit"));
8674  }
8675 
8676  /* We want to preserve the type name. This can be useful when
8677  trying to get the type name of a value that has already been
8678  printed (for instance, if the user did "print VAR; whatis $". */
8679  TYPE_NAME (result) = TYPE_NAME (type0);
8680 
8681  if (constrained_packed_array_p)
8682  {
8683  /* So far, the resulting type has been created as if the original
8684  type was a regular (non-packed) array type. As a result, the
8685  bitsize of the array elements needs to be set again, and the array
8686  length needs to be recomputed based on that bitsize. */
8687  int len = TYPE_LENGTH (result) / TYPE_LENGTH (TYPE_TARGET_TYPE (result));
8688  int elt_bitsize = TYPE_FIELD_BITSIZE (type0, 0);
8689 
8690  TYPE_FIELD_BITSIZE (result, 0) = TYPE_FIELD_BITSIZE (type0, 0);
8691  TYPE_LENGTH (result) = len * elt_bitsize / HOST_CHAR_BIT;
8692  if (TYPE_LENGTH (result) * HOST_CHAR_BIT < len * elt_bitsize)
8693  TYPE_LENGTH (result)++;
8694  }
8695 
8696  TYPE_FIXED_INSTANCE (result) = 1;
8697  return result;
8698 }
8699 
8700 
8701 /* A standard type (containing no dynamically sized components)
8702  corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8703  DVAL describes a record containing any discriminants used in TYPE0,
8704  and may be NULL if there are none, or if the object of type TYPE at
8705  ADDRESS or in VALADDR contains these discriminants.
8706 
8707  If CHECK_TAG is not null, in the case of tagged types, this function
8708  attempts to locate the object's tag and use it to compute the actual
8709  type. However, when ADDRESS is null, we cannot use it to determine the
8710  location of the tag, and therefore compute the tagged type's actual type.
8711  So we return the tagged type without consulting the tag. */
8712 
8713 static struct type *
8714 ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
8715  CORE_ADDR address, struct value *dval, int check_tag)
8716 {
8717  type = ada_check_typedef (type);
8718  switch (TYPE_CODE (type))
8719  {
8720  default:
8721  return type;
8722  case TYPE_CODE_STRUCT:
8723  {
8724  struct type *static_type = to_static_fixed_type (type);
8725  struct type *fixed_record_type =
8726  to_fixed_record_type (type, valaddr, address, NULL);
8727 
8728  /* If STATIC_TYPE is a tagged type and we know the object's address,
8729  then we can determine its tag, and compute the object's actual
8730  type from there. Note that we have to use the fixed record
8731  type (the parent part of the record may have dynamic fields
8732  and the way the location of _tag is expressed may depend on
8733  them). */
8734 
8735  if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
8736  {
8737  struct value *tag =
8739  (fixed_record_type,
8740  valaddr,
8741  address);
8742  struct type *real_type = type_from_tag (tag);
8743  struct value *obj =
8744  value_from_contents_and_address (fixed_record_type,
8745  valaddr,
8746  address);
8747  fixed_record_type = value_type (obj);
8748  if (real_type != NULL)
8749  return to_fixed_record_type
8750  (real_type, NULL,
8752  }
8753 
8754  /* Check to see if there is a parallel ___XVZ variable.
8755  If there is, then it provides the actual size of our type. */
8756  else if (ada_type_name (fixed_record_type) != NULL)
8757  {
8758  const char *name = ada_type_name (fixed_record_type);
8759  char *xvz_name = alloca (strlen (name) + 7 /* "___XVZ\0" */);
8760  int xvz_found = 0;
8761  LONGEST size;
8762 
8763  xsnprintf (xvz_name, strlen (name) + 7, "%s___XVZ", name);
8764  size = get_int_var_value (xvz_name, &xvz_found);
8765  if (xvz_found && TYPE_LENGTH (fixed_record_type) != size)
8766  {
8767  fixed_record_type = copy_type (fixed_record_type);
8768  TYPE_LENGTH (fixed_record_type) = size;
8769 
8770  /* The FIXED_RECORD_TYPE may have be a stub. We have
8771  observed this when the debugging info is STABS, and
8772  apparently it is something that is hard to fix.
8773 
8774  In practice, we don't need the actual type definition
8775  at all, because the presence of the XVZ variable allows us
8776  to assume that there must be a XVS type as well, which we
8777  should be able to use later, when we need the actual type
8778  definition.
8779 
8780  In the meantime, pretend that the "fixed" type we are
8781  returning is NOT a stub, because this can cause trouble
8782  when using this type to create new types targeting it.
8783  Indeed, the associated creation routines often check
8784  whether the target type is a stub and will try to replace
8785  it, thus using a type with the wrong size. This, in turn,
8786  might cause the new type to have the wrong size too.
8787  Consider the case of an array, for instance, where the size
8788  of the array is computed from the number of elements in
8789  our array multiplied by the size of its element. */
8790  TYPE_STUB (fixed_record_type) = 0;
8791  }
8792  }
8793  return fixed_record_type;
8794  }
8795  case TYPE_CODE_ARRAY:
8796  return to_fixed_array_type (type, dval, 1);
8797  case TYPE_CODE_UNION:
8798  if (dval == NULL)
8799  return type;
8800  else
8801  return to_fixed_variant_branch_type (type, valaddr, address, dval);
8802  }
8803 }
8804 
8805 /* The same as ada_to_fixed_type_1, except that it preserves the type
8806  if it is a TYPE_CODE_TYPEDEF of a type that is already fixed.
8807 
8808  The typedef layer needs be preserved in order to differentiate between
8809  arrays and array pointers when both types are implemented using the same
8810  fat pointer. In the array pointer case, the pointer is encoded as
8811  a typedef of the pointer type. For instance, considering:
8812 
8813  type String_Access is access String;
8814  S1 : String_Access := null;
8815 
8816  To the debugger, S1 is defined as a typedef of type String. But
8817  to the user, it is a pointer. So if the user tries to print S1,
8818  we should not dereference the array, but print the array address
8819  instead.
8820 
8821  If we didn't preserve the typedef layer, we would lose the fact that
8822  the type is to be presented as a pointer (needs de-reference before
8823  being printed). And we would also use the source-level type name. */
8824 
8825 struct type *
8826 ada_to_fixed_type (struct type *type, const gdb_byte *valaddr,
8827  CORE_ADDR address, struct value *dval, int check_tag)
8828 
8829 {
8830  struct type *fixed_type =
8831  ada_to_fixed_type_1 (type, valaddr, address, dval, check_tag);
8832 
8833  /* If TYPE is a typedef and its target type is the same as the FIXED_TYPE,
8834  then preserve the typedef layer.
8835 
8836  Implementation note: We can only check the main-type portion of
8837  the TYPE and FIXED_TYPE, because eliminating the typedef layer
8838  from TYPE now returns a type that has the same instance flags
8839  as TYPE. For instance, if TYPE is a "typedef const", and its
8840  target type is a "struct", then the typedef elimination will return
8841  a "const" version of the target type. See check_typedef for more
8842  details about how the typedef layer elimination is done.
8843 
8844  brobecker/2010-11-19: It seems to me that the only case where it is
8845  useful to preserve the typedef layer is when dealing with fat pointers.
8846  Perhaps, we could add a check for that and preserve the typedef layer
8847  only in that situation. But this seems unecessary so far, probably
8848  because we call check_typedef/ada_check_typedef pretty much everywhere.
8849  */
8850  if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8852  == TYPE_MAIN_TYPE (fixed_type)))
8853  return type;
8854 
8855  return fixed_type;
8856 }
8857 
8858 /* A standard (static-sized) type corresponding as well as possible to
8859  TYPE0, but based on no runtime data. */
8860 
8861 static struct type *
8863 {
8864  struct type *type;
8865 
8866  if (type0 == NULL)
8867  return NULL;
8868 
8869  if (TYPE_FIXED_INSTANCE (type0))
8870  return type0;
8871 
8872  type0 = ada_check_typedef (type0);
8873 
8874  switch (TYPE_CODE (type0))
8875  {
8876  default:
8877  return type0;
8878  case TYPE_CODE_STRUCT:
8879  type = dynamic_template_type (type0);
8880  if (type != NULL)
8881  return template_to_static_fixed_type (type);
8882  else
8883  return template_to_static_fixed_type (type0);
8884  case TYPE_CODE_UNION:
8885  type = ada_find_parallel_type (type0, "___XVU");
8886  if (type != NULL)
8887  return template_to_static_fixed_type (type);
8888  else
8889  return template_to_static_fixed_type (type0);
8890  }
8891 }
8892 
8893 /* A static approximation of TYPE with all type wrappers removed. */
8894 
8895 static struct type *
8897 {
8898  if (ada_is_aligner_type (type))
8899  {
8900  struct type *type1 = TYPE_FIELD_TYPE (ada_check_typedef (type), 0);
8901  if (ada_type_name (type1) == NULL)
8902  TYPE_NAME (type1) = ada_type_name (type);
8903 
8904  return static_unwrap_type (type1);
8905  }
8906  else
8907  {
8908  struct type *raw_real_type = ada_get_base_type (type);
8909 
8910  if (raw_real_type == type)
8911  return type;
8912  else
8913  return to_static_fixed_type (raw_real_type);
8914  }
8915 }
8916 
8917 /* In some cases, incomplete and private types require
8918  cross-references that are not resolved as records (for example,
8919  type Foo;
8920  type FooP is access Foo;
8921  V: FooP;
8922  type Foo is array ...;
8923  ). In these cases, since there is no mechanism for producing
8924  cross-references to such types, we instead substitute for FooP a
8925  stub enumeration type that is nowhere resolved, and whose tag is
8926  the name of the actual type. Call these types "non-record stubs". */
8927 
8928 /* A type equivalent to TYPE that is not a non-record stub, if one
8929  exists, otherwise TYPE. */
8930 
8931 struct type *
8933 {
8934  if (type == NULL)
8935  return NULL;
8936 
8937  /* If our type is a typedef type of a fat pointer, then we're done.
8938  We don't want to strip the TYPE_CODE_TYPDEF layer, because this is
8939  what allows us to distinguish between fat pointers that represent
8940  array types, and fat pointers that represent array access types
8941  (in both cases, the compiler implements them as fat pointers). */
8942  if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF
8944  return type;
8945 
8946  CHECK_TYPEDEF (type);
8947  if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
8948  || !TYPE_STUB (type)
8949  || TYPE_TAG_NAME (type) == NULL)
8950  return type;
8951  else
8952  {
8953  const char *name = TYPE_TAG_NAME (type);
8954  struct type *type1 = ada_find_any_type (name);
8955 
8956  if (type1 == NULL)
8957  return type;
8958 
8959  /* TYPE1 might itself be a TYPE_CODE_TYPEDEF (this can happen with
8960  stubs pointing to arrays, as we don't create symbols for array
8961  types, only for the typedef-to-array types). If that's the case,
8962  strip the typedef layer. */
8963  if (TYPE_CODE (type1) == TYPE_CODE_TYPEDEF)
8964  type1 = ada_check_typedef (type1);
8965 
8966  return type1;
8967  }
8968 }
8969 
8970 /* A value representing the data at VALADDR/ADDRESS as described by
8971  type TYPE0, but with a standard (static-sized) type that correctly
8972  describes it. If VAL0 is not NULL and TYPE0 already is a standard
8973  type, then return VAL0 [this feature is simply to avoid redundant
8974  creation of struct values]. */
8975 
8976 static struct value *
8978  struct value *val0)
8979 {
8980  struct type *type = ada_to_fixed_type (type0, 0, address, NULL, 1);
8981 
8982  if (type == type0 && val0 != NULL)
8983  return val0;
8984  else
8985  return value_from_contents_and_address (type, 0, address);
8986 }
8987 
8988 /* A value representing VAL, but with a standard (static-sized) type
8989  that correctly describes it. Does not necessarily create a new
8990  value. */
8991 
8992 struct value *
8994 {
8995  val = unwrap_value (val);
8997  value_address (val),
8998  val);
8999  return val;
9000 }
9001 
9002 
9003 /* Attributes */
9004 
9005 /* Table mapping attribute numbers to names.
9006  NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
9007 
9008 static const char *attribute_names[] = {
9009  "<?>",
9010 
9011  "first",
9012  "last",
9013  "length",
9014  "image",
9015  "max",
9016  "min",
9017  "modulus",
9018  "pos",
9019  "size",
9020  "tag",
9021  "val",
9022  0
9023 };
9024 
9025 const char *
9027 {
9028  if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
9029  return attribute_names[n - OP_ATR_FIRST + 1];
9030  else
9031  return attribute_names[0];
9032 }
9033 
9034 /* Evaluate the 'POS attribute applied to ARG. */
9035 
9036 static LONGEST
9037 pos_atr (struct value *arg)
9038 {
9039  struct value *val = coerce_ref (arg);
9040  struct type *type = value_type (val);
9041  LONGEST result;
9042 
9043  if (!discrete_type_p (type))
9044  error (_("'POS only defined on discrete types"));
9045 
9046  if (!discrete_position (type, value_as_long (val), &result))
9047  error (_("enumeration value is invalid: can't find 'POS"));
9048 
9049  return result;
9050 }
9051 
9052 static struct value *
9053 value_pos_atr (struct type *type, struct value *arg)
9054 {
9055  return value_from_longest (type, pos_atr (arg));
9056 }
9057 
9058 /* Evaluate the TYPE'VAL attribute applied to ARG. */
9059 
9060 static struct value *
9061 value_val_atr (struct type *type, struct value *arg)
9062 {
9063  if (!discrete_type_p (type))
9064  error (_("'VAL only defined on discrete types"));
9065  if (!integer_type_p (value_type (arg)))
9066  error (_("'VAL requires integral argument"));
9067 
9068  if (TYPE_CODE (type) == TYPE_CODE_ENUM)
9069  {
9070  long pos = value_as_long (arg);
9071 
9072  if (pos < 0 || pos >= TYPE_NFIELDS (type))
9073  error (_("argument to 'VAL out of range"));
9074  return value_from_longest (type, TYPE_FIELD_ENUMVAL (type, pos));
9075  }
9076  else
9077  return value_from_longest (type, value_as_long (arg));
9078 }
9079 
9080 
9081  /* Evaluation */
9082 
9083 /* True if TYPE appears to be an Ada character type.
9084  [At the moment, this is true only for Character and Wide_Character;
9085  It is a heuristic test that could stand improvement]. */
9086 
9087 int
9089 {
9090  const char *name;
9091 
9092  /* If the type code says it's a character, then assume it really is,
9093  and don't check any further. */
9094  if (TYPE_CODE (type) == TYPE_CODE_CHAR)
9095  return 1;
9096 
9097  /* Otherwise, assume it's a character type iff it is a discrete type
9098  with a known character type name. */
9099  name = ada_type_name (type);
9100  return (name != NULL
9101  && (TYPE_CODE (type) == TYPE_CODE_INT
9102  || TYPE_CODE (type) == TYPE_CODE_RANGE)
9103  && (strcmp (name, "character") == 0
9104  || strcmp (name, "wide_character") == 0
9105  || strcmp (name, "wide_wide_character") == 0
9106  || strcmp (name, "unsigned char") == 0));
9107 }
9108 
9109 /* True if TYPE appears to be an Ada string type. */
9110 
9111 int
9113 {
9114  type = ada_check_typedef (type);
9115  if (type != NULL
9116  && TYPE_CODE (type) != TYPE_CODE_PTR
9117  && (ada_is_simple_array_type (type)
9118  || ada_is_array_descriptor_type (type))
9119  && ada_array_arity (type) == 1)
9120  {
9121  struct type *elttype = ada_array_element_type (type, 1);
9122 
9123  return ada_is_character_type (elttype);
9124  }
9125  else
9126  return 0;
9127 }
9128 
9129 /* The compiler sometimes provides a parallel XVS type for a given
9130  PAD type. Normally, it is safe to follow the PAD type directly,
9131  but older versions of the compiler have a bug that causes the offset
9132  of its "F" field to be wrong. Following that field in that case
9133  would lead to incorrect results, but this can be worked around
9134  by ignoring the PAD type and using the associated XVS type instead.
9135 
9136  Set to True if the debugger should trust the contents of PAD types.
9137  Otherwise, ignore the PAD type if there is a parallel XVS type. */
9138 static int trust_pad_over_xvs = 1;
9139 
9140 /* True if TYPE is a struct type introduced by the compiler to force the
9141  alignment of a value. Such types have a single field with a
9142  distinctive name. */
9143 
9144 int
9146 {
9147  type = ada_check_typedef (type);
9148 
9149  if (!trust_pad_over_xvs && ada_find_parallel_type (type, "___XVS") != NULL)
9150  return 0;
9151 
9152  return (TYPE_CODE (type) == TYPE_CODE_STRUCT
9153  && TYPE_NFIELDS (type) == 1
9154  && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
9155 }
9156 
9157 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
9158  the parallel type. */
9159 
9160 struct type *
9161 ada_get_base_type (struct type *raw_type)
9162 {
9163  struct type *real_type_namer;
9164  struct type *raw_real_type;
9165 
9166  if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
9167  return raw_type;
9168 
9169  if (ada_is_aligner_type (raw_type))
9170  /* The encoding specifies that we should always use the aligner type.
9171  So, even if this aligner type has an associated XVS type, we should
9172  simply ignore it.
9173 
9174  According to the compiler gurus, an XVS type parallel to an aligner
9175  type may exist because of a stabs limitation. In stabs, aligner
9176  types are empty because the field has a variable-sized type, and
9177  thus cannot actually be used as an aligner type. As a result,
9178  we need the associated parallel XVS type to decode the type.
9179  Since the policy in the compiler is to not change the internal
9180  representation based on the debugging info format, we sometimes
9181  end up having a redundant XVS type parallel to the aligner type. */
9182  return raw_type;
9183 
9184  real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
9185  if (real_type_namer == NULL
9186  || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
9187  || TYPE_NFIELDS (real_type_namer) != 1)
9188  return raw_type;
9189 
9190  if (TYPE_CODE (TYPE_FIELD_TYPE (real_type_namer, 0)) != TYPE_CODE_REF)
9191  {
9192  /* This is an older encoding form where the base type needs to be
9193  looked up by name. We prefer the newer enconding because it is
9194  more efficient. */
9195  raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
9196  if (raw_real_type == NULL)
9197  return raw_type;
9198  else
9199  return raw_real_type;
9200  }
9201 
9202  /* The field in our XVS type is a reference to the base type. */
9203  return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (real_type_namer, 0));
9204 }
9205 
9206 /* The type of value designated by TYPE, with all aligners removed. */
9207 
9208 struct type *
9210 {
9211  if (ada_is_aligner_type (type))
9212  return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
9213  else
9214  return ada_get_base_type (type);
9215 }
9216 
9217 
9218 /* The address of the aligned value in an object at address VALADDR
9219  having type TYPE. Assumes ada_is_aligner_type (TYPE). */
9220 
9221 const gdb_byte *
9222 ada_aligned_value_addr (struct type *type, const gdb_byte *valaddr)
9223 {
9224  if (ada_is_aligner_type (type))
9225  return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
9226  valaddr +
9227  TYPE_FIELD_BITPOS (type,
9228  0) / TARGET_CHAR_BIT);
9229  else
9230  return valaddr;
9231 }
9232 
9233 
9234 
9235 /* The printed representation of an enumeration literal with encoded
9236  name NAME. The value is good to the next call of ada_enum_name. */
9237 const char *
9238 ada_enum_name (const char *name)
9239 {
9240  static char *result;
9241  static size_t result_len = 0;
9242  char *tmp;
9243 
9244  /* First, unqualify the enumeration name:
9245  1. Search for the last '.' character. If we find one, then skip
9246  all the preceding characters, the unqualified name starts
9247  right after that dot.
9248  2. Otherwise, we may be debugging on a target where the compiler
9249  translates dots into "__". Search forward for double underscores,
9250  but stop searching when we hit an overloading suffix, which is
9251  of the form "__" followed by digits. */
9252 
9253  tmp = strrchr (name, '.');
9254  if (tmp != NULL)
9255  name = tmp + 1;
9256  else
9257  {
9258  while ((tmp = strstr (name, "__")) != NULL)
9259  {
9260  if (isdigit (tmp[2]))
9261  break;
9262  else
9263  name = tmp + 2;
9264  }
9265  }
9266 
9267  if (name[0] == 'Q')
9268  {
9269  int v;
9270 
9271  if (name[1] == 'U' || name[1] == 'W')
9272  {
9273  if (sscanf (name + 2, "%x", &v) != 1)
9274  return name;
9275  }
9276  else
9277  return name;
9278 
9279  GROW_VECT (result, result_len, 16);
9280  if (isascii (v) && isprint (v))
9281  xsnprintf (result, result_len, "'%c'", v);
9282  else if (name[1] == 'U')
9283  xsnprintf (result, result_len, "[\"%02x\"]", v);
9284  else
9285  xsnprintf (result, result_len, "[\"%04x\"]", v);
9286 
9287  return result;
9288  }
9289  else
9290  {
9291  tmp = strstr (name, "__");
9292  if (tmp == NULL)
9293  tmp = strstr (name, "$");
9294  if (tmp != NULL)
9295  {
9296  GROW_VECT (result, result_len, tmp - name + 1);
9297  strncpy (result, name, tmp - name);
9298  result[tmp - name] = '\0';
9299  return result;
9300  }
9301 
9302  return name;
9303  }
9304 }
9305 
9306 /* Evaluate the subexpression of EXP starting at *POS as for
9307  evaluate_type, updating *POS to point just past the evaluated
9308  expression. */
9309 
9310 static struct value *
9311 evaluate_subexp_type (struct expression *exp, int *pos)
9312 {
9314 }
9315 
9316 /* If VAL is wrapped in an aligner or subtype wrapper, return the
9317  value it wraps. */
9318 
9319 static struct value *
9320 unwrap_value (struct value *val)
9321 {
9322  struct type *type = ada_check_typedef (value_type (val));
9323 
9324  if (ada_is_aligner_type (type))
9325  {
9326  struct value *v = ada_value_struct_elt (val, "F", 0);
9327  struct type *val_type = ada_check_typedef (value_type (v));
9328 
9329  if (ada_type_name (val_type) == NULL)
9330  TYPE_NAME (val_type) = ada_type_name (type);
9331 
9332  return unwrap_value (v);
9333  }
9334  else
9335  {
9336  struct type *raw_real_type =
9338 
9339  /* If there is no parallel XVS or XVE type, then the value is
9340  already unwrapped. Return it without further modification. */
9341  if ((type == raw_real_type)
9342  && ada_find_parallel_type (type, "___XVE") == NULL)
9343  return val;
9344 
9345  return
9347  (val, ada_to_fixed_type (raw_real_type, 0,
9348  value_address (val),
9349  NULL, 1));
9350  }
9351 }
9352 
9353 static struct value *
9354 cast_to_fixed (struct type *type, struct value *arg)
9355 {
9356  LONGEST val;
9357 
9358  if (type == value_type (arg))
9359  return arg;
9360  else if (ada_is_fixed_point_type (value_type (arg)))
9361  val = ada_float_to_fixed (type,
9363  value_as_long (arg)));
9364  else
9365  {
9366  DOUBLEST argd = value_as_double (arg);
9367 
9368  val = ada_float_to_fixed (type, argd);
9369  }
9370 
9371  return value_from_longest (type, val);
9372 }
9373 
9374 static struct value *
9375 cast_from_fixed (struct type *type, struct value *arg)
9376 {
9377  DOUBLEST val = ada_fixed_to_float (value_type (arg),
9378  value_as_long (arg));
9379 
9380  return value_from_double (type, val);
9381 }
9382 
9383 /* Given two array types T1 and T2, return nonzero iff both arrays
9384  contain the same number of elements. */
9385 
9386 static int
9387 ada_same_array_size_p (struct type *t1, struct type *t2)
9388 {
9389  LONGEST lo1, hi1, lo2, hi2;
9390 
9391  /* Get the array bounds in order to verify that the size of
9392  the two arrays match. */
9393  if (!get_array_bounds (t1, &lo1, &hi1)
9394  || !get_array_bounds (t2, &lo2, &hi2))
9395  error (_("unable to determine array bounds"));
9396 
9397  /* To make things easier for size comparison, normalize a bit
9398  the case of empty arrays by making sure that the difference
9399  between upper bound and lower bound is always -1. */
9400  if (lo1 > hi1)
9401  hi1 = lo1 - 1;
9402  if (lo2 > hi2)
9403  hi2 = lo2 - 1;
9404 
9405  return (hi1 - lo1 == hi2 - lo2);
9406 }
9407 
9408 /* Assuming that VAL is an array of integrals, and TYPE represents
9409  an array with the same number of elements, but with wider integral
9410  elements, return an array "casted" to TYPE. In practice, this
9411  means that the returned array is built by casting each element
9412  of the original array into TYPE's (wider) element type. */
9413 
9414 static struct value *
9416 {
9417  struct type *elt_type = TYPE_TARGET_TYPE (type);
9418  LONGEST lo, hi;
9419  struct value *res;
9420  LONGEST i;
9421 
9422  /* Verify that both val and type are arrays of scalars, and
9423  that the size of val's elements is smaller than the size
9424  of type's element. */
9425  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
9431 
9432  if (!get_array_bounds (type, &lo, &hi))
9433  error (_("unable to determine array bounds"));
9434 
9435  res = allocate_value (type);
9436 
9437  /* Promote each array element. */
9438  for (i = 0; i < hi - lo + 1; i++)
9439  {
9440  struct value *elt = value_cast (elt_type, value_subscript (val, lo + i));
9441 
9442  memcpy (value_contents_writeable (res) + (i * TYPE_LENGTH (elt_type)),
9443  value_contents_all (elt), TYPE_LENGTH (elt_type));
9444  }
9445 
9446  return res;
9447 }
9448 
9449 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
9450  return the converted value. */
9451 
9452 static struct value *
9453 coerce_for_assign (struct type *type, struct value *val)
9454 {
9455  struct type *type2 = value_type (val);
9456 
9457  if (type == type2)
9458  return val;
9459 
9460  type2 = ada_check_typedef (type2);
9461  type = ada_check_typedef (type);
9462 
9463  if (TYPE_CODE (type2) == TYPE_CODE_PTR
9464  && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9465  {
9466  val = ada_value_ind (val);
9467  type2 = value_type (val);
9468  }
9469 
9470  if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
9471  && TYPE_CODE (type) == TYPE_CODE_ARRAY)
9472  {
9473  if (!ada_same_array_size_p (type, type2))
9474  error (_("cannot assign arrays of different length"));
9475 
9476  if (is_integral_type (TYPE_TARGET_TYPE (type))
9477  && is_integral_type (TYPE_TARGET_TYPE (type2))
9478  && TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9479  < TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9480  {
9481  /* Allow implicit promotion of the array elements to
9482  a wider type. */
9483  return ada_promote_array_of_integrals (type, val);
9484  }
9485 
9486  if (TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
9487  != TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
9488  error (_("Incompatible types in assignment"));
9489  deprecated_set_value_type (val, type);
9490  }
9491  return val;
9492 }
9493 
9494 static struct value *
9495 ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
9496 {
9497  struct value *val;
9498  struct type *type1, *type2;
9499  LONGEST v, v1, v2;
9500 
9501  arg1 = coerce_ref (arg1);
9502  arg2 = coerce_ref (arg2);
9503  type1 = get_base_type (ada_check_typedef (value_type (arg1)));
9504  type2 = get_base_type (ada_check_typedef (value_type (arg2)));
9505 
9506  if (TYPE_CODE (type1) != TYPE_CODE_INT
9507  || TYPE_CODE (type2) != TYPE_CODE_INT)
9508  return value_binop (arg1, arg2, op);
9509 
9510  switch (op)
9511  {
9512  case BINOP_MOD:
9513  case BINOP_DIV:
9514  case BINOP_REM:
9515  break;
9516  default:
9517  return value_binop (arg1, arg2, op);
9518  }
9519 
9520  v2 = value_as_long (arg2);
9521  if (v2 == 0)
9522  error (_("second operand of %s must not be zero."), op_string (op));
9523 
9524  if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
9525  return value_binop (arg1, arg2, op);
9526 
9527  v1 = value_as_long (arg1);
9528  switch (op)
9529  {
9530  case BINOP_DIV:
9531  v = v1 / v2;
9532  if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
9533  v += v > 0 ? -1 : 1;
9534  break;
9535  case BINOP_REM:
9536  v = v1 % v2;
9537  if (v * v1 < 0)
9538  v -= v2;
9539  break;
9540  default:
9541  /* Should not reach this point. */
9542  v = 0;
9543  }
9544 
9545  val = allocate_value (type1);
9547  TYPE_LENGTH (value_type (val)),
9548  gdbarch_byte_order (get_type_arch (type1)), v);
9549  return val;
9550 }
9551 
9552 static int
9553 ada_value_equal (struct value *arg1, struct value *arg2)
9554 {
9557  {
9558  /* Automatically dereference any array reference before
9559  we attempt to perform the comparison. */
9560  arg1 = ada_coerce_ref (arg1);
9561  arg2 = ada_coerce_ref (arg2);
9562 
9563  arg1 = ada_coerce_to_simple_array (arg1);
9564  arg2 = ada_coerce_to_simple_array (arg2);
9565  if (TYPE_CODE (value_type (arg1)) != TYPE_CODE_ARRAY
9566  || TYPE_CODE (value_type (arg2)) != TYPE_CODE_ARRAY)
9567  error (_("Attempt to compare array with non-array"));
9568  /* FIXME: The following works only for types whose
9569  representations use all bits (no padding or undefined bits)
9570  and do not have user-defined equality. */
9571  return
9572  TYPE_LENGTH (value_type (arg1)) == TYPE_LENGTH (value_type (arg2))
9573  && memcmp (value_contents (arg1), value_contents (arg2),
9574  TYPE_LENGTH (value_type (arg1))) == 0;
9575  }
9576  return value_equal (arg1, arg2);
9577 }
9578 
9579 /* Total number of component associations in the aggregate starting at
9580  index PC in EXP. Assumes that index PC is the start of an
9581  OP_AGGREGATE. */
9582 
9583 static int
9584 num_component_specs (struct expression *exp, int pc)
9585 {
9586  int n, m, i;
9587 
9588  m = exp->elts[pc + 1].longconst;
9589  pc += 3;
9590  n = 0;
9591  for (i = 0; i < m; i += 1)
9592  {
9593  switch (exp->elts[pc].opcode)
9594  {
9595  default:
9596  n += 1;
9597  break;
9598  case OP_CHOICES:
9599  n += exp->elts[pc + 1].longconst;
9600  break;
9601  }
9602  ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP);
9603  }
9604  return n;
9605 }
9606 
9607 /* Assign the result of evaluating EXP starting at *POS to the INDEXth
9608  component of LHS (a simple array or a record), updating *POS past
9609  the expression, assuming that LHS is contained in CONTAINER. Does
9610  not modify the inferior's memory, nor does it modify LHS (unless
9611  LHS == CONTAINER). */
9612 
9613 static void
9614 assign_component (struct value *container, struct value *lhs, LONGEST index,
9615  struct expression *exp, int *pos)
9616 {
9617  struct value *mark = value_mark ();
9618  struct value *elt;
9619 
9620  if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY)
9621  {
9622  struct type *index_type = builtin_type (exp->gdbarch)->builtin_int;
9623  struct value *index_val = value_from_longest (index_type, index);
9624 
9625  elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val));
9626  }
9627  else
9628  {
9629  elt = ada_index_struct_field (index, lhs, 0, value_type (lhs));
9630  elt = ada_to_fixed_value (elt);
9631  }
9632 
9633  if (exp->elts[*pos].opcode == OP_AGGREGATE)
9634  assign_aggregate (container, elt, exp, pos, EVAL_NORMAL);
9635  else
9636  value_assign_to_component (container, elt,
9637  ada_evaluate_subexp (NULL, exp, pos,
9638  EVAL_NORMAL));
9639 
9640  value_free_to_mark (mark);
9641 }
9642 
9643 /* Assuming that LHS represents an lvalue having a record or array
9644  type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment
9645  of that aggregate's value to LHS, advancing *POS past the
9646  aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an
9647  lvalue containing LHS (possibly LHS itself). Does not modify
9648  the inferior's memory, nor does it modify the contents of
9649  LHS (unless == CONTAINER). Returns the modified CONTAINER. */
9650 
9651 static struct value *
9652 assign_aggregate (struct value *container,
9653  struct value *lhs, struct expression *exp,
9654  int *pos, enum noside noside)
9655 {
9656  struct type *lhs_type;
9657  int n = exp->elts[*pos+1].longconst;
9658  LONGEST low_index, high_index;
9659  int num_specs;
9660  LONGEST *indices;
9661  int max_indices, num_indices;
9662  int i;
9663 
9664  *pos += 3;
9665  if (noside != EVAL_NORMAL)
9666  {
9667  for (i = 0; i < n; i += 1)
9668  ada_evaluate_subexp (NULL, exp, pos, noside);
9669  return container;
9670  }
9671 
9672  container = ada_coerce_ref (container);
9673  if (ada_is_direct_array_type (value_type (container)))
9674  container = ada_coerce_to_simple_array (container);
9675  lhs = ada_coerce_ref (lhs);
9676  if (!deprecated_value_modifiable (lhs))
9677  error (_("Left operand of assignment is not a modifiable lvalue."));
9678 
9679  lhs_type = value_type (lhs);
9680  if (ada_is_direct_array_type (lhs_type))
9681  {
9682  lhs = ada_coerce_to_simple_array (lhs);
9683  lhs_type = value_type (lhs);
9684  low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type);
9685  high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type);
9686  }
9687  else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT)
9688  {
9689  low_index = 0;
9690  high_index = num_visible_fields (lhs_type) - 1;
9691  }
9692  else
9693  error (_("Left-hand side must be array or record."));
9694 
9695  num_specs = num_component_specs (exp, *pos - 3);
9696  max_indices = 4 * num_specs + 4;
9697  indices = alloca (max_indices * sizeof (indices[0]));
9698  indices[0] = indices[1] = low_index - 1;
9699  indices[2] = indices[3] = high_index + 1;
9700  num_indices = 4;
9701 
9702  for (i = 0; i < n; i += 1)
9703  {
9704  switch (exp->elts[*pos].opcode)
9705  {
9706  case OP_CHOICES:
9707  aggregate_assign_from_choices (container, lhs, exp, pos, indices,
9708  &num_indices, max_indices,
9709  low_index, high_index);
9710  break;
9711  case OP_POSITIONAL:
9712  aggregate_assign_positional (container, lhs, exp, pos, indices,
9713  &num_indices, max_indices,
9714  low_index, high_index);
9715  break;
9716  case OP_OTHERS:
9717  if (i != n-1)
9718  error (_("Misplaced 'others' clause"));
9719  aggregate_assign_others (container, lhs, exp, pos, indices,
9720  num_indices, low_index, high_index);
9721  break;
9722  default:
9723  error (_("Internal error: bad aggregate clause"));
9724  }
9725  }
9726 
9727  return container;
9728 }
9729 
9730 /* Assign into the component of LHS indexed by the OP_POSITIONAL
9731  construct at *POS, updating *POS past the construct, given that
9732  the positions are relative to lower bound LOW, where HIGH is the
9733  upper bound. Record the position in INDICES[0 .. MAX_INDICES-1]
9734  updating *NUM_INDICES as needed. CONTAINER is as for
9735  assign_aggregate. */
9736 static void
9738  struct value *lhs, struct expression *exp,
9739  int *pos, LONGEST *indices, int *num_indices,
9740  int max_indices, LONGEST low, LONGEST high)
9741 {
9742  LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low;
9743 
9744  if (ind - 1 == high)
9745  warning (_("Extra components in aggregate ignored."));
9746  if (ind <= high)
9747  {
9748  add_component_interval (ind, ind, indices, num_indices, max_indices);
9749  *pos += 3;
9750  assign_component (container, lhs, ind, exp, pos);
9751  }
9752  else
9753  ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9754 }
9755 
9756 /* Assign into the components of LHS indexed by the OP_CHOICES
9757  construct at *POS, updating *POS past the construct, given that
9758  the allowable indices are LOW..HIGH. Record the indices assigned
9759  to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as
9760  needed. CONTAINER is as for assign_aggregate. */
9761 static void
9763  struct value *lhs, struct expression *exp,
9764  int *pos, LONGEST *indices, int *num_indices,
9765  int max_indices, LONGEST low, LONGEST high)
9766 {
9767  int j;
9768  int n_choices = longest_to_int (exp->elts[*pos+1].longconst);
9769  int choice_pos, expr_pc;
9770  int is_array = ada_is_direct_array_type (value_type (lhs));
9771 
9772  choice_pos = *pos += 3;
9773 
9774  for (j = 0; j < n_choices; j += 1)
9775  ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9776  expr_pc = *pos;
9777  ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9778 
9779  for (j = 0; j < n_choices; j += 1)
9780  {
9781  LONGEST lower, upper;
9782  enum exp_opcode op = exp->elts[choice_pos].opcode;
9783 
9784  if (op == OP_DISCRETE_RANGE)
9785  {
9786  choice_pos += 1;
9787  lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9788  EVAL_NORMAL));
9789  upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos,
9790  EVAL_NORMAL));
9791  }
9792  else if (is_array)
9793  {
9794  lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos,
9795  EVAL_NORMAL));
9796  upper = lower;
9797  }
9798  else
9799  {
9800  int ind;
9801  const char *name;
9802 
9803  switch (op)
9804  {
9805  case OP_NAME:
9806  name = &exp->elts[choice_pos + 2].string;
9807  break;
9808  case OP_VAR_VALUE:
9809  name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol);
9810  break;
9811  default:
9812  error (_("Invalid record component association."));
9813  }
9814  ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP);
9815  ind = 0;
9816  if (! find_struct_field (name, value_type (lhs), 0,
9817  NULL, NULL, NULL, NULL, &ind))
9818  error (_("Unknown component name: %s."), name);
9819  lower = upper = ind;
9820  }
9821 
9822  if (lower <= upper && (lower < low || upper > high))
9823  error (_("Index in component association out of bounds."));
9824 
9825  add_component_interval (lower, upper, indices, num_indices,
9826  max_indices);
9827  while (lower <= upper)
9828  {
9829  int pos1;
9830 
9831  pos1 = expr_pc;
9832  assign_component (container, lhs, lower, exp, &pos1);
9833  lower += 1;
9834  }
9835  }
9836 }
9837 
9838 /* Assign the value of the expression in the OP_OTHERS construct in
9839  EXP at *POS into the components of LHS indexed from LOW .. HIGH that
9840  have not been previously assigned. The index intervals already assigned
9841  are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the
9842  OP_OTHERS clause. CONTAINER is as for assign_aggregate. */
9843 static void
9844 aggregate_assign_others (struct value *container,
9845  struct value *lhs, struct expression *exp,
9846  int *pos, LONGEST *indices, int num_indices,
9847  LONGEST low, LONGEST high)
9848 {
9849  int i;
9850  int expr_pc = *pos + 1;
9851 
9852  for (i = 0; i < num_indices - 2; i += 2)
9853  {
9854  LONGEST ind;
9855 
9856  for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1)
9857  {
9858  int localpos;
9859 
9860  localpos = expr_pc;
9861  assign_component (container, lhs, ind, exp, &localpos);
9862  }
9863  }
9864  ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP);
9865 }
9866 
9867 /* Add the interval [LOW .. HIGH] to the sorted set of intervals
9868  [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ],
9869  modifying *SIZE as needed. It is an error if *SIZE exceeds
9870  MAX_SIZE. The resulting intervals do not overlap. */
9871 static void
9873  LONGEST* indices, int *size, int max_size)
9874 {
9875  int i, j;
9876 
9877  for (i = 0; i < *size; i += 2) {
9878  if (high >= indices[i] && low <= indices[i + 1])
9879  {
9880  int kh;
9881 
9882  for (kh = i + 2; kh < *size; kh += 2)
9883  if (high < indices[kh])
9884  break;
9885  if (low < indices[i])
9886  indices[i] = low;
9887  indices[i + 1] = indices[kh - 1];
9888  if (high > indices[i + 1])
9889  indices[i + 1] = high;
9890  memcpy (indices + i + 2, indices + kh, *size - kh);
9891  *size -= kh - i - 2;
9892  return;
9893  }
9894  else if (high < indices[i])
9895  break;
9896  }
9897 
9898  if (*size == max_size)
9899  error (_("Internal error: miscounted aggregate components."));
9900  *size += 2;
9901  for (j = *size-1; j >= i+2; j -= 1)
9902  indices[j] = indices[j - 2];
9903  indices[i] = low;
9904  indices[i + 1] = high;
9905 }
9906 
9907 /* Perform and Ada cast of ARG2 to type TYPE if the type of ARG2
9908  is different. */
9909 
9910 static struct value *
9911 ada_value_cast (struct type *type, struct value *arg2, enum noside noside)
9912 {
9913  if (type == ada_check_typedef (value_type (arg2)))
9914  return arg2;
9915 
9916  if (ada_is_fixed_point_type (type))
9917  return (cast_to_fixed (type, arg2));
9918 
9919  if (ada_is_fixed_point_type (value_type (arg2)))
9920  return cast_from_fixed (type, arg2);
9921 
9922  return value_cast (type, arg2);
9923 }
9924 
9925 /* Evaluating Ada expressions, and printing their result.
9926  ------------------------------------------------------
9927 
9928  1. Introduction:
9929  ----------------
9930 
9931  We usually evaluate an Ada expression in order to print its value.
9932  We also evaluate an expression in order to print its type, which
9933  happens during the EVAL_AVOID_SIDE_EFFECTS phase of the evaluation,
9934  but we'll focus mostly on the EVAL_NORMAL phase. In practice, the
9935  EVAL_AVOID_SIDE_EFFECTS phase allows us to simplify certain aspects of
9936  the evaluation compared to the EVAL_NORMAL, but is otherwise very
9937  similar.
9938 
9939  Evaluating expressions is a little more complicated for Ada entities
9940  than it is for entities in languages such as C. The main reason for
9941  this is that Ada provides types whose definition might be dynamic.
9942  One example of such types is variant records. Or another example
9943  would be an array whose bounds can only be known at run time.
9944 
9945  The following description is a general guide as to what should be
9946  done (and what should NOT be done) in order to evaluate an expression
9947  involving such types, and when. This does not cover how the semantic
9948  information is encoded by GNAT as this is covered separatly. For the
9949  document used as the reference for the GNAT encoding, see exp_dbug.ads
9950  in the GNAT sources.
9951 
9952  Ideally, we should embed each part of this description next to its
9953  associated code. Unfortunately, the amount of code is so vast right
9954  now that it's hard to see whether the code handling a particular
9955  situation might be duplicated or not. One day, when the code is
9956  cleaned up, this guide might become redundant with the comments
9957  inserted in the code, and we might want to remove it.
9958 
9959  2. ``Fixing'' an Entity, the Simple Case:
9960  -----------------------------------------
9961 
9962  When evaluating Ada expressions, the tricky issue is that they may
9963  reference entities whose type contents and size are not statically
9964  known. Consider for instance a variant record:
9965 
9966  type Rec (Empty : Boolean := True) is record
9967  case Empty is
9968  when True => null;
9969  when False => Value : Integer;
9970  end case;
9971  end record;
9972  Yes : Rec := (Empty => False, Value => 1);
9973  No : Rec := (empty => True);
9974 
9975  The size and contents of that record depends on the value of the
9976  descriminant (Rec.Empty). At this point, neither the debugging
9977  information nor the associated type structure in GDB are able to
9978  express such dynamic types. So what the debugger does is to create
9979  "fixed" versions of the type that applies to the specific object.
9980  We also informally refer to this opperation as "fixing" an object,
9981  which means creating its associated fixed type.
9982 
9983  Example: when printing the value of variable "Yes" above, its fixed
9984  type would look like this:
9985 
9986  type Rec is record
9987  Empty : Boolean;
9988  Value : Integer;
9989  end record;
9990 
9991  On the other hand, if we printed the value of "No", its fixed type
9992  would become:
9993 
9994  type Rec is record
9995  Empty : Boolean;
9996  end record;
9997 
9998  Things become a little more complicated when trying to fix an entity
9999  with a dynamic type that directly contains another dynamic type,
10000  such as an array of variant records, for instance. There are
10001  two possible cases: Arrays, and records.
10002 
10003  3. ``Fixing'' Arrays:
10004  ---------------------
10005 
10006  The type structure in GDB describes an array in terms of its bounds,
10007  and the type of its elements. By design, all elements in the array
10008  have the same type and we cannot represent an array of variant elements
10009  using the current type structure in GDB. When fixing an array,
10010  we cannot fix the array element, as we would potentially need one
10011  fixed type per element of the array. As a result, the best we can do
10012  when fixing an array is to produce an array whose bounds and size
10013  are correct (allowing us to read it from memory), but without having
10014  touched its element type. Fixing each element will be done later,
10015  when (if) necessary.
10016 
10017  Arrays are a little simpler to handle than records, because the same
10018  amount of memory is allocated for each element of the array, even if
10019  the amount of space actually used by each element differs from element
10020  to element. Consider for instance the following array of type Rec:
10021 
10022  type Rec_Array is array (1 .. 2) of Rec;
10023 
10024  The actual amount of memory occupied by each element might be different
10025  from element to element, depending on the value of their discriminant.
10026  But the amount of space reserved for each element in the array remains
10027  fixed regardless. So we simply need to compute that size using
10028  the debugging information available, from which we can then determine
10029  the array size (we multiply the number of elements of the array by
10030  the size of each element).
10031 
10032  The simplest case is when we have an array of a constrained element
10033  type. For instance, consider the following type declarations:
10034 
10035  type Bounded_String (Max_Size : Integer) is
10036  Length : Integer;
10037  Buffer : String (1 .. Max_Size);
10038  end record;
10039  type Bounded_String_Array is array (1 ..2) of Bounded_String (80);
10040 
10041  In this case, the compiler describes the array as an array of
10042  variable-size elements (identified by its XVS suffix) for which
10043  the size can be read in the parallel XVZ variable.
10044 
10045  In the case of an array of an unconstrained element type, the compiler
10046  wraps the array element inside a private PAD type. This type should not
10047  be shown to the user, and must be "unwrap"'ed before printing. Note
10048  that we also use the adjective "aligner" in our code to designate
10049  these wrapper types.
10050 
10051  In some cases, the size allocated for each element is statically
10052  known. In that case, the PAD type already has the correct size,
10053  and the array element should remain unfixed.
10054 
10055  But there are cases when this size is not statically known.
10056  For instance, assuming that "Five" is an integer variable:
10057 
10058  type Dynamic is array (1 .. Five) of Integer;
10059  type Wrapper (Has_Length : Boolean := False) is record
10060  Data : Dynamic;
10061  case Has_Length is
10062  when True => Length : Integer;
10063  when False => null;
10064  end case;
10065  end record;
10066  type Wrapper_Array is array (1 .. 2) of Wrapper;
10067 
10068  Hello : Wrapper_Array := (others => (Has_Length => True,
10069  Data => (others => 17),
10070  Length => 1));
10071 
10072 
10073  The debugging info would describe variable Hello as being an
10074  array of a PAD type. The size of that PAD type is not statically
10075  known, but can be determined using a parallel XVZ variable.
10076  In that case, a copy of the PAD type with the correct size should
10077  be used for the fixed array.
10078 
10079  3. ``Fixing'' record type objects:
10080  ----------------------------------
10081 
10082  Things are slightly different from arrays in the case of dynamic
10083  record types. In this case, in order to compute the associated
10084  fixed type, we need to determine the size and offset of each of
10085  its components. This, in turn, requires us to compute the fixed
10086  type of each of these components.
10087 
10088  Consider for instance the example:
10089 
10090  type Bounded_String (Max_Size : Natural) is record
10091  Str : String (1 .. Max_Size);
10092  Length : Natural;
10093  end record;
10094  My_String : Bounded_String (Max_Size => 10);
10095 
10096  In that case, the position of field "Length" depends on the size
10097  of field Str, which itself depends on the value of the Max_Size
10098  discriminant. In order to fix the type of variable My_String,
10099  we need to fix the type of field Str. Therefore, fixing a variant
10100  record requires us to fix each of its components.
10101 
10102  However, if a component does not have a dynamic size, the component
10103  should not be fixed. In particular, fields that use a PAD type
10104  should not fixed. Here is an example where this might happen
10105  (assuming type Rec above):
10106 
10107  type Container (Big : Boolean) is record
10108  First : Rec;
10109  After : Integer;
10110  case Big is
10111  when True => Another : Integer;
10112  when False => null;
10113  end case;
10114  end record;
10115  My_Container : Container := (Big => False,
10116  First => (Empty => True),
10117  After => 42);
10118 
10119  In that example, the compiler creates a PAD type for component First,
10120  whose size is constant, and then positions the component After just
10121  right after it. The offset of component After is therefore constant
10122  in this case.
10123 
10124  The debugger computes the position of each field based on an algorithm
10125  that uses, among other things, the actual position and size of the field
10126  preceding it. Let's now imagine that the user is trying to print
10127  the value of My_Container. If the type fixing was recursive, we would
10128  end up computing the offset of field After based on the size of the
10129  fixed version of field First. And since in our example First has
10130  only one actual field, the size of the fixed type is actually smaller
10131  than the amount of space allocated to that field, and thus we would
10132  compute the wrong offset of field After.
10133 
10134  To make things more complicated, we need to watch out for dynamic
10135  components of variant records (identified by the ___XVL suffix in
10136  the component name). Even if the target type is a PAD type, the size
10137  of that type might not be statically known. So the PAD type needs
10138  to be unwrapped and the resulting type needs to be fixed. Otherwise,
10139  we might end up with the wrong size for our component. This can be
10140  observed with the following type declarations:
10141 
10142  type Octal is new Integer range 0 .. 7;
10143  type Octal_Array is array (Positive range <>) of Octal;
10144  pragma Pack (Octal_Array);
10145 
10146  type Octal_Buffer (Size : Positive) is record
10147  Buffer : Octal_Array (1 .. Size);
10148  Length : Integer;
10149  end record;
10150 
10151  In that case, Buffer is a PAD type whose size is unset and needs
10152  to be computed by fixing the unwrapped type.
10153 
10154  4. When to ``Fix'' un-``Fixed'' sub-elements of an entity:
10155  ----------------------------------------------------------
10156 
10157  Lastly, when should the sub-elements of an entity that remained unfixed
10158  thus far, be actually fixed?
10159 
10160  The answer is: Only when referencing that element. For instance
10161  when selecting one component of a record, this specific component
10162  should be fixed at that point in time. Or when printing the value
10163  of a record, each component should be fixed before its value gets
10164  printed. Similarly for arrays, the element of the array should be
10165  fixed when printing each element of the array, or when extracting
10166  one element out of that array. On the other hand, fixing should
10167  not be performed on the elements when taking a slice of an array!
10168 
10169  Note that one of the side-effects of miscomputing the offset and
10170  size of each field is that we end up also miscomputing the size
10171  of the containing type. This can have adverse results when computing
10172  the value of an entity. GDB fetches the value of an entity based
10173  on the size of its type, and thus a wrong size causes GDB to fetch
10174  the wrong amount of memory. In the case where the computed size is
10175  too small, GDB fetches too little data to print the value of our
10176  entiry. Results in this case as unpredicatble, as we usually read
10177  past the buffer containing the data =:-o. */
10178 
10179 /* Implement the evaluate_exp routine in the exp_descriptor structure
10180  for the Ada language. */
10181 
10182 static struct value *
10183 ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
10184  int *pos, enum noside noside)
10185 {
10186  enum exp_opcode op;
10187  int tem;
10188  int pc;
10189  int preeval_pos;
10190  struct value *arg1 = NULL, *arg2 = NULL, *arg3;
10191  struct type *type;
10192  int nargs, oplen;
10193  struct value **argvec;
10194 
10195  pc = *pos;
10196  *pos += 1;
10197  op = exp->elts[pc].opcode;
10198 
10199  switch (op)
10200  {
10201  default:
10202  *pos -= 1;
10203  arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10204 
10205  if (noside == EVAL_NORMAL)
10206  arg1 = unwrap_value (arg1);
10207 
10208  /* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
10209  then we need to perform the conversion manually, because
10210  evaluate_subexp_standard doesn't do it. This conversion is
10211  necessary in Ada because the different kinds of float/fixed
10212  types in Ada have different representations.
10213 
10214  Similarly, we need to perform the conversion from OP_LONG
10215  ourselves. */
10216  if ((op == OP_DOUBLE || op == OP_LONG) && expect_type != NULL)
10217  arg1 = ada_value_cast (expect_type, arg1, noside);
10218 
10219  return arg1;
10220 
10221  case OP_STRING:
10222  {
10223  struct value *result;
10224 
10225  *pos -= 1;
10226  result = evaluate_subexp_standard (expect_type, exp, pos, noside);
10227  /* The result type will have code OP_STRING, bashed there from
10228  OP_ARRAY. Bash it back. */
10229  if (TYPE_CODE (value_type (result)) == TYPE_CODE_STRING)
10230  TYPE_CODE (value_type (result)) = TYPE_CODE_ARRAY;
10231  return result;
10232  }
10233 
10234  case UNOP_CAST:
10235  (*pos) += 2;
10236  type = exp->elts[pc + 1].type;
10237  arg1 = evaluate_subexp (type, exp, pos, noside);
10238  if (noside == EVAL_SKIP)
10239  goto nosideret;
10240  arg1 = ada_value_cast (type, arg1, noside);
10241  return arg1;
10242 
10243  case UNOP_QUAL:
10244  (*pos) += 2;
10245  type = exp->elts[pc + 1].type;
10246  return ada_evaluate_subexp (type, exp, pos, noside);
10247 
10248  case BINOP_ASSIGN:
10249  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10250  if (exp->elts[*pos].opcode == OP_AGGREGATE)
10251  {
10252  arg1 = assign_aggregate (arg1, arg1, exp, pos, noside);
10253  if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10254  return arg1;
10255  return ada_value_assign (arg1, arg1);
10256  }
10257  /* Force the evaluation of the rhs ARG2 to the type of the lhs ARG1,
10258  except if the lhs of our assignment is a convenience variable.
10259  In the case of assigning to a convenience variable, the lhs
10260  should be exactly the result of the evaluation of the rhs. */
10261  type = value_type (arg1);
10262  if (VALUE_LVAL (arg1) == lval_internalvar)
10263  type = NULL;
10264  arg2 = evaluate_subexp (type, exp, pos, noside);
10265  if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
10266  return arg1;
10267  if (ada_is_fixed_point_type (value_type (arg1)))
10268  arg2 = cast_to_fixed (value_type (arg1), arg2);
10269  else if (ada_is_fixed_point_type (value_type (arg2)))
10270  error
10271  (_("Fixed-point values must be assigned to fixed-point variables"));
10272  else
10273  arg2 = coerce_for_assign (value_type (arg1), arg2);
10274  return ada_value_assign (arg1, arg2);
10275 
10276  case BINOP_ADD:
10277  arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10278  arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10279  if (noside == EVAL_SKIP)
10280  goto nosideret;
10281  if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10282  return (value_from_longest
10283  (value_type (arg1),
10284  value_as_long (arg1) + value_as_long (arg2)));
10285  if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10286  return (value_from_longest
10287  (value_type (arg2),
10288  value_as_long (arg1) + value_as_long (arg2)));
10289  if ((ada_is_fixed_point_type (value_type (arg1))
10290  || ada_is_fixed_point_type (value_type (arg2)))
10291  && value_type (arg1) != value_type (arg2))
10292  error (_("Operands of fixed-point addition must have the same type"));
10293  /* Do the addition, and cast the result to the type of the first
10294  argument. We cannot cast the result to a reference type, so if
10295  ARG1 is a reference type, find its underlying type. */
10296  type = value_type (arg1);
10297  while (TYPE_CODE (type) == TYPE_CODE_REF)
10298  type = TYPE_TARGET_TYPE (type);
10299  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10300  return value_cast (type, value_binop (arg1, arg2, BINOP_ADD));
10301 
10302  case BINOP_SUB:
10303  arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
10304  arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
10305  if (noside == EVAL_SKIP)
10306  goto nosideret;
10307  if (TYPE_CODE (value_type (arg1)) == TYPE_CODE_PTR)
10308  return (value_from_longest
10309  (value_type (arg1),
10310  value_as_long (arg1) - value_as_long (arg2)));
10311  if (TYPE_CODE (value_type (arg2)) == TYPE_CODE_PTR)
10312  return (value_from_longest
10313  (value_type (arg2),
10314  value_as_long (arg1) - value_as_long (arg2)));
10315  if ((ada_is_fixed_point_type (value_type (arg1))
10316  || ada_is_fixed_point_type (value_type (arg2)))
10317  && value_type (arg1) != value_type (arg2))
10318  error (_("Operands of fixed-point subtraction "
10319  "must have the same type"));
10320  /* Do the substraction, and cast the result to the type of the first
10321  argument. We cannot cast the result to a reference type, so if
10322  ARG1 is a reference type, find its underlying type. */
10323  type = value_type (arg1);
10324  while (TYPE_CODE (type) == TYPE_CODE_REF)
10325  type = TYPE_TARGET_TYPE (type);
10326  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10327  return value_cast (type, value_binop (arg1, arg2, BINOP_SUB));
10328 
10329  case BINOP_MUL:
10330  case BINOP_DIV:
10331  case BINOP_REM:
10332  case BINOP_MOD:
10333  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10334  arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10335  if (noside == EVAL_SKIP)
10336  goto nosideret;
10337  else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10338  {
10339  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10340  return value_zero (value_type (arg1), not_lval);
10341  }
10342  else
10343  {
10344  type = builtin_type (exp->gdbarch)->builtin_double;
10345  if (ada_is_fixed_point_type (value_type (arg1)))
10346  arg1 = cast_from_fixed (type, arg1);
10347  if (ada_is_fixed_point_type (value_type (arg2)))
10348  arg2 = cast_from_fixed (type, arg2);
10349  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10350  return ada_value_binop (arg1, arg2, op);
10351  }
10352 
10353  case BINOP_EQUAL:
10354  case BINOP_NOTEQUAL:
10355  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10356  arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
10357  if (noside == EVAL_SKIP)
10358  goto nosideret;
10359  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10360  tem = 0;
10361  else
10362  {
10363  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10364  tem = ada_value_equal (arg1, arg2);
10365  }
10366  if (op == BINOP_NOTEQUAL)
10367  tem = !tem;
10368  type = language_bool_type (exp->language_defn, exp->gdbarch);
10369  return value_from_longest (type, (LONGEST) tem);
10370 
10371  case UNOP_NEG:
10372  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10373  if (noside == EVAL_SKIP)
10374  goto nosideret;
10375  else if (ada_is_fixed_point_type (value_type (arg1)))
10376  return value_cast (value_type (arg1), value_neg (arg1));
10377  else
10378  {
10379  unop_promote (exp->language_defn, exp->gdbarch, &arg1);
10380  return value_neg (arg1);
10381  }
10382 
10383  case BINOP_LOGICAL_AND:
10384  case BINOP_LOGICAL_OR:
10385  case UNOP_LOGICAL_NOT:
10386  {
10387  struct value *val;
10388 
10389  *pos -= 1;
10390  val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10391  type = language_bool_type (exp->language_defn, exp->gdbarch);
10392  return value_cast (type, val);
10393  }
10394 
10395  case BINOP_BITWISE_AND:
10396  case BINOP_BITWISE_IOR:
10397  case BINOP_BITWISE_XOR:
10398  {
10399  struct value *val;
10400 
10402  *pos = pc;
10403  val = evaluate_subexp_standard (expect_type, exp, pos, noside);
10404 
10405  return value_cast (value_type (arg1), val);
10406  }
10407 
10408  case OP_VAR_VALUE:
10409  *pos -= 1;
10410 
10411  if (noside == EVAL_SKIP)
10412  {
10413  *pos += 4;
10414  goto nosideret;
10415  }
10416 
10417  if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
10418  /* Only encountered when an unresolved symbol occurs in a
10419  context other than a function call, in which case, it is
10420  invalid. */
10421  error (_("Unexpected unresolved symbol, %s, during evaluation"),
10422  SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
10423 
10424  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10425  {
10426  type = static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol));
10427  /* Check to see if this is a tagged type. We also need to handle
10428  the case where the type is a reference to a tagged type, but
10429  we have to be careful to exclude pointers to tagged types.
10430  The latter should be shown as usual (as a pointer), whereas
10431  a reference should mostly be transparent to the user. */
10432  if (ada_is_tagged_type (type, 0)
10433  || (TYPE_CODE (type) == TYPE_CODE_REF
10434  && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0)))
10435  {
10436  /* Tagged types are a little special in the fact that the real
10437  type is dynamic and can only be determined by inspecting the
10438  object's tag. This means that we need to get the object's
10439  value first (EVAL_NORMAL) and then extract the actual object
10440  type from its tag.
10441 
10442  Note that we cannot skip the final step where we extract
10443  the object type from its tag, because the EVAL_NORMAL phase
10444  results in dynamic components being resolved into fixed ones.
10445  This can cause problems when trying to print the type
10446  description of tagged types whose parent has a dynamic size:
10447  We use the type name of the "_parent" component in order
10448  to print the name of the ancestor type in the type description.
10449  If that component had a dynamic size, the resolution into
10450  a fixed type would result in the loss of that type name,
10451  thus preventing us from printing the name of the ancestor
10452  type in the type description. */
10453  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
10454 
10455  if (TYPE_CODE (type) != TYPE_CODE_REF)
10456  {
10457  struct type *actual_type;
10458 
10459  actual_type = type_from_tag (ada_value_tag (arg1));
10460  if (actual_type == NULL)
10461  /* If, for some reason, we were unable to determine
10462  the actual type from the tag, then use the static
10463  approximation that we just computed as a fallback.
10464  This can happen if the debugging information is
10465  incomplete, for instance. */
10466  actual_type = type;
10467  return value_zero (actual_type, not_lval);
10468  }
10469  else
10470  {
10471  /* In the case of a ref, ada_coerce_ref takes care
10472  of determining the actual type. But the evaluation
10473  should return a ref as it should be valid to ask
10474  for its address; so rebuild a ref after coerce. */
10475  arg1 = ada_coerce_ref (arg1);
10476  return value_ref (arg1);
10477  }
10478  }
10479 
10480  /* Records and unions for which GNAT encodings have been
10481  generated need to be statically fixed as well.
10482  Otherwise, non-static fixing produces a type where
10483  all dynamic properties are removed, which prevents "ptype"
10484  from being able to completely describe the type.
10485  For instance, a case statement in a variant record would be
10486  replaced by the relevant components based on the actual
10487  value of the discriminants. */
10488  if ((TYPE_CODE (type) == TYPE_CODE_STRUCT
10489  && dynamic_template_type (type) != NULL)
10490  || (TYPE_CODE (type) == TYPE_CODE_UNION
10491  && ada_find_parallel_type (type, "___XVU") != NULL))
10492  {
10493  *pos += 4;
10494  return value_zero (to_static_fixed_type (type), not_lval);
10495  }
10496  }
10497 
10498  arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
10499  return ada_to_fixed_value (arg1);
10500 
10501  case OP_FUNCALL:
10502  (*pos) += 2;
10503 
10504  /* Allocate arg vector, including space for the function to be
10505  called in argvec[0] and a terminating NULL. */
10506  nargs = longest_to_int (exp->elts[pc + 1].longconst);
10507  argvec =
10508  (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
10509 
10510  if (exp->elts[*pos].opcode == OP_VAR_VALUE
10511  && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
10512  error (_("Unexpected unresolved symbol, %s, during evaluation"),
10513  SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
10514  else
10515  {
10516  for (tem = 0; tem <= nargs; tem += 1)
10517  argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10518  argvec[tem] = 0;
10519 
10520  if (noside == EVAL_SKIP)
10521  goto nosideret;
10522  }
10523 
10525  (desc_base_type (value_type (argvec[0]))))
10526  argvec[0] = ada_coerce_to_simple_array (argvec[0]);
10527  else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10528  && TYPE_FIELD_BITSIZE (value_type (argvec[0]), 0) != 0)
10529  /* This is a packed array that has already been fixed, and
10530  therefore already coerced to a simple array. Nothing further
10531  to do. */
10532  ;
10533  else if (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_REF
10534  || (TYPE_CODE (value_type (argvec[0])) == TYPE_CODE_ARRAY
10535  && VALUE_LVAL (argvec[0]) == lval_memory))
10536  argvec[0] = value_addr (argvec[0]);
10537 
10538  type = ada_check_typedef (value_type (argvec[0]));
10539 
10540  /* Ada allows us to implicitly dereference arrays when subscripting
10541  them. So, if this is an array typedef (encoding use for array
10542  access types encoded as fat pointers), strip it now. */
10543  if (TYPE_CODE (type) == TYPE_CODE_TYPEDEF)
10544  type = ada_typedef_target_type (type);
10545 
10546  if (TYPE_CODE (type) == TYPE_CODE_PTR)
10547  {
10548  switch (TYPE_CODE (ada_check_typedef (TYPE_TARGET_TYPE (type))))
10549  {
10550  case TYPE_CODE_FUNC:
10551  type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10552  break;
10553  case TYPE_CODE_ARRAY:
10554  break;
10555  case TYPE_CODE_STRUCT:
10556  if (noside != EVAL_AVOID_SIDE_EFFECTS)
10557  argvec[0] = ada_value_ind (argvec[0]);
10558  type = ada_check_typedef (TYPE_TARGET_TYPE (type));
10559  break;
10560  default:
10561  error (_("cannot subscript or call something of type `%s'"),
10562  ada_type_name (value_type (argvec[0])));
10563  break;
10564  }
10565  }
10566 
10567  switch (TYPE_CODE (type))
10568  {
10569  case TYPE_CODE_FUNC:
10570  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10571  {
10572  struct type *rtype = TYPE_TARGET_TYPE (type);
10573 
10574  if (TYPE_GNU_IFUNC (type))
10575  return allocate_value (TYPE_TARGET_TYPE (rtype));
10576  return allocate_value (rtype);
10577  }
10578  return call_function_by_hand (argvec[0], nargs, argvec + 1);
10580  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10581  /* We don't know anything about what the internal
10582  function might return, but we have to return
10583  something. */
10584  return value_zero (builtin_type (exp->gdbarch)->builtin_int,
10585  not_lval);
10586  else
10587  return call_internal_function (exp->gdbarch, exp->language_defn,
10588  argvec[0], nargs, argvec + 1);
10589 
10590  case TYPE_CODE_STRUCT:
10591  {
10592  int arity;
10593 
10594  arity = ada_array_arity (type);
10595  type = ada_array_element_type (type, nargs);
10596  if (type == NULL)
10597  error (_("cannot subscript or call a record"));
10598  if (arity != nargs)
10599  error (_("wrong number of subscripts; expecting %d"), arity);
10600  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10601  return value_zero (ada_aligned_type (type), lval_memory);
10602  return
10604  (argvec[0], nargs, argvec + 1));
10605  }
10606  case TYPE_CODE_ARRAY:
10607  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10608  {
10609  type = ada_array_element_type (type, nargs);
10610  if (type == NULL)
10611  error (_("element type of array unknown"));
10612  else
10613  return value_zero (ada_aligned_type (type), lval_memory);
10614  }
10615  return
10617  (ada_coerce_to_simple_array (argvec[0]),
10618  nargs, argvec + 1));
10619  case TYPE_CODE_PTR: /* Pointer to array */
10620  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10621  {
10622  type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
10623  type = ada_array_element_type (type, nargs);
10624  if (type == NULL)
10625  error (_("element type of array unknown"));
10626  else
10627  return value_zero (ada_aligned_type (type), lval_memory);
10628  }
10629  return
10631  nargs, argvec + 1));
10632 
10633  default:
10634  error (_("Attempt to index or call something other than an "
10635  "array or function"));
10636  }
10637 
10638  case TERNOP_SLICE:
10639  {
10640  struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10641  struct value *low_bound_val =
10642  evaluate_subexp (NULL_TYPE, exp, pos, noside);
10643  struct value *high_bound_val =
10644  evaluate_subexp (NULL_TYPE, exp, pos, noside);
10645  LONGEST low_bound;
10646  LONGEST high_bound;
10647 
10648  low_bound_val = coerce_ref (low_bound_val);
10649  high_bound_val = coerce_ref (high_bound_val);
10650  low_bound = value_as_long (low_bound_val);
10651  high_bound = value_as_long (high_bound_val);
10652 
10653  if (noside == EVAL_SKIP)
10654  goto nosideret;
10655 
10656  /* If this is a reference to an aligner type, then remove all
10657  the aligners. */
10658  if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10660  TYPE_TARGET_TYPE (value_type (array)) =
10662 
10664  error (_("cannot slice a packed array"));
10665 
10666  /* If this is a reference to an array or an array lvalue,
10667  convert to a pointer. */
10668  if (TYPE_CODE (value_type (array)) == TYPE_CODE_REF
10669  || (TYPE_CODE (value_type (array)) == TYPE_CODE_ARRAY
10670  && VALUE_LVAL (array) == lval_memory))
10671  array = value_addr (array);
10672 
10673  if (noside == EVAL_AVOID_SIDE_EFFECTS
10675  (value_type (array))))
10676  return empty_array (ada_type_of_array (array, 0), low_bound);
10677 
10678  array = ada_coerce_to_simple_array_ptr (array);
10679 
10680  /* If we have more than one level of pointer indirection,
10681  dereference the value until we get only one level. */
10682  while (TYPE_CODE (value_type (array)) == TYPE_CODE_PTR
10683  && (TYPE_CODE (TYPE_TARGET_TYPE (value_type (array)))
10684  == TYPE_CODE_PTR))
10685  array = value_ind (array);
10686 
10687  /* Make sure we really do have an array type before going further,
10688  to avoid a SEGV when trying to get the index type or the target
10689  type later down the road if the debug info generated by
10690  the compiler is incorrect or incomplete. */
10691  if (!ada_is_simple_array_type (value_type (array)))
10692  error (_("cannot take slice of non-array"));
10693 
10694  if (TYPE_CODE (ada_check_typedef (value_type (array)))
10695  == TYPE_CODE_PTR)
10696  {
10697  struct type *type0 = ada_check_typedef (value_type (array));
10698 
10699  if (high_bound < low_bound || noside == EVAL_AVOID_SIDE_EFFECTS)
10700  return empty_array (TYPE_TARGET_TYPE (type0), low_bound);
10701  else
10702  {
10703  struct type *arr_type0 =
10704  to_fixed_array_type (TYPE_TARGET_TYPE (type0), NULL, 1);
10705 
10706  return ada_value_slice_from_ptr (array, arr_type0,
10707  longest_to_int (low_bound),
10708  longest_to_int (high_bound));
10709  }
10710  }
10711  else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10712  return array;
10713  else if (high_bound < low_bound)
10714  return empty_array (value_type (array), low_bound);
10715  else
10716  return ada_value_slice (array, longest_to_int (low_bound),
10717  longest_to_int (high_bound));
10718  }
10719 
10720  case UNOP_IN_RANGE:
10721  (*pos) += 2;
10722  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10723  type = check_typedef (exp->elts[pc + 1].type);
10724 
10725  if (noside == EVAL_SKIP)
10726  goto nosideret;
10727 
10728  switch (TYPE_CODE (type))
10729  {
10730  default:
10731  lim_warning (_("Membership test incompletely implemented; "
10732  "always returns true"));
10733  type = language_bool_type (exp->language_defn, exp->gdbarch);
10734  return value_from_longest (type, (LONGEST) 1);
10735 
10736  case TYPE_CODE_RANGE:
10737  arg2 = value_from_longest (type, TYPE_LOW_BOUND (type));
10738  arg3 = value_from_longest (type, TYPE_HIGH_BOUND (type));
10739  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10740  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10741  type = language_bool_type (exp->language_defn, exp->gdbarch);
10742  return
10743  value_from_longest (type,
10744  (value_less (arg1, arg3)
10745  || value_equal (arg1, arg3))
10746  && (value_less (arg2, arg1)
10747  || value_equal (arg2, arg1)));
10748  }
10749 
10750  case BINOP_IN_BOUNDS:
10751  (*pos) += 2;
10752  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10753  arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10754 
10755  if (noside == EVAL_SKIP)
10756  goto nosideret;
10757 
10758  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10759  {
10760  type = language_bool_type (exp->language_defn, exp->gdbarch);
10761  return value_zero (type, not_lval);
10762  }
10763 
10764  tem = longest_to_int (exp->elts[pc + 1].longconst);
10765 
10766  type = ada_index_type (value_type (arg2), tem, "range");
10767  if (!type)
10768  type = value_type (arg1);
10769 
10770  arg3 = value_from_longest (type, ada_array_bound (arg2, tem, 1));
10771  arg2 = value_from_longest (type, ada_array_bound (arg2, tem, 0));
10772 
10773  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10774  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10775  type = language_bool_type (exp->language_defn, exp->gdbarch);
10776  return
10777  value_from_longest (type,
10778  (value_less (arg1, arg3)
10779  || value_equal (arg1, arg3))
10780  && (value_less (arg2, arg1)
10781  || value_equal (arg2, arg1)));
10782 
10783  case TERNOP_IN_RANGE:
10784  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10785  arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10786  arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10787 
10788  if (noside == EVAL_SKIP)
10789  goto nosideret;
10790 
10791  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10792  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg3);
10793  type = language_bool_type (exp->language_defn, exp->gdbarch);
10794  return
10795  value_from_longest (type,
10796  (value_less (arg1, arg3)
10797  || value_equal (arg1, arg3))
10798  && (value_less (arg2, arg1)
10799  || value_equal (arg2, arg1)));
10800 
10801  case OP_ATR_FIRST:
10802  case OP_ATR_LAST:
10803  case OP_ATR_LENGTH:
10804  {
10805  struct type *type_arg;
10806 
10807  if (exp->elts[*pos].opcode == OP_TYPE)
10808  {
10809  evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10810  arg1 = NULL;
10811  type_arg = check_typedef (exp->elts[pc + 2].type);
10812  }
10813  else
10814  {
10815  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10816  type_arg = NULL;
10817  }
10818 
10819  if (exp->elts[*pos].opcode != OP_LONG)
10820  error (_("Invalid operand to '%s"), ada_attribute_name (op));
10821  tem = longest_to_int (exp->elts[*pos + 2].longconst);
10822  *pos += 4;
10823 
10824  if (noside == EVAL_SKIP)
10825  goto nosideret;
10826 
10827  if (type_arg == NULL)
10828  {
10829  arg1 = ada_coerce_ref (arg1);
10830 
10832  arg1 = ada_coerce_to_simple_array (arg1);
10833 
10834  if (op == OP_ATR_LENGTH)
10835  type = builtin_type (exp->gdbarch)->builtin_int;
10836  else
10837  {
10838  type = ada_index_type (value_type (arg1), tem,
10839  ada_attribute_name (op));
10840  if (type == NULL)
10841  type = builtin_type (exp->gdbarch)->builtin_int;
10842  }
10843 
10844  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10845  return allocate_value (type);
10846 
10847  switch (op)
10848  {
10849  default: /* Should never happen. */
10850  error (_("unexpected attribute encountered"));
10851  case OP_ATR_FIRST:
10852  return value_from_longest
10853  (type, ada_array_bound (arg1, tem, 0));
10854  case OP_ATR_LAST:
10855  return value_from_longest
10856  (type, ada_array_bound (arg1, tem, 1));
10857  case OP_ATR_LENGTH:
10858  return value_from_longest
10859  (type, ada_array_length (arg1, tem));
10860  }
10861  }
10862  else if (discrete_type_p (type_arg))
10863  {
10864  struct type *range_type;
10865  const char *name = ada_type_name (type_arg);
10866 
10867  range_type = NULL;
10868  if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
10869  range_type = to_fixed_range_type (type_arg, NULL);
10870  if (range_type == NULL)
10871  range_type = type_arg;
10872  switch (op)
10873  {
10874  default:
10875  error (_("unexpected attribute encountered"));
10876  case OP_ATR_FIRST:
10877  return value_from_longest
10878  (range_type, ada_discrete_type_low_bound (range_type));
10879  case OP_ATR_LAST:
10880  return value_from_longest
10881  (range_type, ada_discrete_type_high_bound (range_type));
10882  case OP_ATR_LENGTH:
10883  error (_("the 'length attribute applies only to array types"));
10884  }
10885  }
10886  else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
10887  error (_("unimplemented type attribute"));
10888  else
10889  {
10890  LONGEST low, high;
10891 
10892  if (ada_is_constrained_packed_array_type (type_arg))
10893  type_arg = decode_constrained_packed_array_type (type_arg);
10894 
10895  if (op == OP_ATR_LENGTH)
10896  type = builtin_type (exp->gdbarch)->builtin_int;
10897  else
10898  {
10899  type = ada_index_type (type_arg, tem, ada_attribute_name (op));
10900  if (type == NULL)
10901  type = builtin_type (exp->gdbarch)->builtin_int;
10902  }
10903 
10904  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10905  return allocate_value (type);
10906 
10907  switch (op)
10908  {
10909  default:
10910  error (_("unexpected attribute encountered"));
10911  case OP_ATR_FIRST:
10912  low = ada_array_bound_from_type (type_arg, tem, 0);
10913  return value_from_longest (type, low);
10914  case OP_ATR_LAST:
10915  high = ada_array_bound_from_type (type_arg, tem, 1);
10916  return value_from_longest (type, high);
10917  case OP_ATR_LENGTH:
10918  low = ada_array_bound_from_type (type_arg, tem, 0);
10919  high = ada_array_bound_from_type (type_arg, tem, 1);
10920  return value_from_longest (type, high - low + 1);
10921  }
10922  }
10923  }
10924 
10925  case OP_ATR_TAG:
10926  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10927  if (noside == EVAL_SKIP)
10928  goto nosideret;
10929 
10930  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10931  return value_zero (ada_tag_type (arg1), not_lval);
10932 
10933  return ada_value_tag (arg1);
10934 
10935  case OP_ATR_MIN:
10936  case OP_ATR_MAX:
10937  evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10938  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10939  arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10940  if (noside == EVAL_SKIP)
10941  goto nosideret;
10942  else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10943  return value_zero (value_type (arg1), not_lval);
10944  else
10945  {
10946  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
10947  return value_binop (arg1, arg2,
10948  op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
10949  }
10950 
10951  case OP_ATR_MODULUS:
10952  {
10953  struct type *type_arg = check_typedef (exp->elts[pc + 2].type);
10954 
10955  evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10956  if (noside == EVAL_SKIP)
10957  goto nosideret;
10958 
10959  if (!ada_is_modular_type (type_arg))
10960  error (_("'modulus must be applied to modular type"));
10961 
10962  return value_from_longest (TYPE_TARGET_TYPE (type_arg),
10963  ada_modulus (type_arg));
10964  }
10965 
10966 
10967  case OP_ATR_POS:
10968  evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10969  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10970  if (noside == EVAL_SKIP)
10971  goto nosideret;
10972  type = builtin_type (exp->gdbarch)->builtin_int;
10973  if (noside == EVAL_AVOID_SIDE_EFFECTS)
10974  return value_zero (type, not_lval);
10975  else
10976  return value_pos_atr (type, arg1);
10977 
10978  case OP_ATR_SIZE:
10979  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10980  type = value_type (arg1);
10981 
10982  /* If the argument is a reference, then dereference its type, since
10983  the user is really asking for the size of the actual object,
10984  not the size of the pointer. */
10985  if (TYPE_CODE (type) == TYPE_CODE_REF)
10986  type = TYPE_TARGET_TYPE (type);
10987 
10988  if (noside == EVAL_SKIP)
10989  goto nosideret;
10990  else if (noside == EVAL_AVOID_SIDE_EFFECTS)
10992  else
10994  TARGET_CHAR_BIT * TYPE_LENGTH (type));
10995 
10996  case OP_ATR_VAL:
10997  evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
10998  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
10999  type = exp->elts[pc + 2].type;
11000  if (noside == EVAL_SKIP)
11001  goto nosideret;
11002  else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11003  return value_zero (type, not_lval);
11004  else
11005  return value_val_atr (type, arg1);
11006 
11007  case BINOP_EXP:
11008  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11009  arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11010  if (noside == EVAL_SKIP)
11011  goto nosideret;
11012  else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11013  return value_zero (value_type (arg1), not_lval);
11014  else
11015  {
11016  /* For integer exponentiation operations,
11017  only promote the first argument. */
11018  if (is_integral_type (value_type (arg2)))
11019  unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11020  else
11021  binop_promote (exp->language_defn, exp->gdbarch, &arg1, &arg2);
11022 
11023  return value_binop (arg1, arg2, op);
11024  }
11025 
11026  case UNOP_PLUS:
11027  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11028  if (noside == EVAL_SKIP)
11029  goto nosideret;
11030  else
11031  return arg1;
11032 
11033  case UNOP_ABS:
11034  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11035  if (noside == EVAL_SKIP)
11036  goto nosideret;
11037  unop_promote (exp->language_defn, exp->gdbarch, &arg1);
11038  if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
11039  return value_neg (arg1);
11040  else
11041  return arg1;
11042 
11043  case UNOP_IND:
11044  preeval_pos = *pos;
11045  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11046  if (noside == EVAL_SKIP)
11047  goto nosideret;
11048  type = ada_check_typedef (value_type (arg1));
11049  if (noside == EVAL_AVOID_SIDE_EFFECTS)
11050  {
11051  if (ada_is_array_descriptor_type (type))
11052  /* GDB allows dereferencing GNAT array descriptors. */
11053  {
11054  struct type *arrType = ada_type_of_array (arg1, 0);
11055 
11056  if (arrType == NULL)
11057  error (_("Attempt to dereference null array pointer."));
11058  return value_at_lazy (arrType, 0);
11059  }
11060  else if (TYPE_CODE (type) == TYPE_CODE_PTR
11061  || TYPE_CODE (type) == TYPE_CODE_REF
11062  /* In C you can dereference an array to get the 1st elt. */
11063  || TYPE_CODE (type) == TYPE_CODE_ARRAY)
11064  {
11065  /* As mentioned in the OP_VAR_VALUE case, tagged types can
11066  only be determined by inspecting the object's tag.
11067  This means that we need to evaluate completely the
11068  expression in order to get its type. */
11069 
11070  if ((TYPE_CODE (type) == TYPE_CODE_REF
11071  || TYPE_CODE (type) == TYPE_CODE_PTR)
11072  && ada_is_tagged_type (TYPE_TARGET_TYPE (type), 0))
11073  {
11074  arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11075  EVAL_NORMAL);
11076  type = value_type (ada_value_ind (arg1));
11077  }
11078  else
11079  {
11080  type = to_static_fixed_type
11082  (ada_check_typedef (TYPE_TARGET_TYPE (type))));
11083  }
11084  ada_ensure_varsize_limit (type);
11085  return value_zero (type, lval_memory);
11086  }
11087  else if (TYPE_CODE (type) == TYPE_CODE_INT)
11088  {
11089  /* GDB allows dereferencing an int. */
11090  if (expect_type == NULL)
11091  return value_zero (builtin_type (exp->gdbarch)->builtin_int,
11092  lval_memory);
11093  else
11094  {
11095  expect_type =
11096  to_static_fixed_type (ada_aligned_type (expect_type));
11097  return value_zero (expect_type, lval_memory);
11098  }
11099  }
11100  else
11101  error (_("Attempt to take contents of a non-pointer value."));
11102  }
11103  arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
11104  type = ada_check_typedef (value_type (arg1));
11105 
11106  if (TYPE_CODE (type) == TYPE_CODE_INT)
11107  /* GDB allows dereferencing an int. If we were given
11108  the expect_type, then use that as the target type.
11109  Otherwise, assume that the target type is an int. */
11110  {
11111  if (expect_type != NULL)
11112  return ada_value_ind (value_cast (lookup_pointer_type (expect_type),
11113  arg1));
11114  else
11116  (CORE_ADDR) value_as_address (arg1));
11117  }
11118 
11119  if (ada_is_array_descriptor_type (type))
11120  /* GDB allows dereferencing GNAT array descriptors. */
11121  return ada_coerce_to_simple_array (arg1);
11122  else
11123  return ada_value_ind (arg1);
11124 
11125  case STRUCTOP_STRUCT:
11126  tem = longest_to_int (exp->elts[pc + 1].longconst);
11127  (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
11128  preeval_pos = *pos;
11129  arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
11130  if (noside == EVAL_SKIP)
11131  goto nosideret;
11132  if (noside == EVAL_AVOID_SIDE_EFFECTS)
11133  {
11134  struct type *type1 = value_type (arg1);
11135 
11136  if (ada_is_tagged_type (type1, 1))
11137  {
11138  type = ada_lookup_struct_elt_type (type1,
11139  &exp->elts[pc + 2].string,
11140  1, 1, NULL);
11141 
11142  /* If the field is not found, check if it exists in the
11143  extension of this object's type. This means that we
11144  need to evaluate completely the expression. */
11145 
11146  if (type == NULL)
11147  {
11148  arg1 = evaluate_subexp (NULL_TYPE, exp, &preeval_pos,
11149  EVAL_NORMAL);
11150  arg1 = ada_value_struct_elt (arg1,
11151  &exp->elts[pc + 2].string,
11152  0);
11153  arg1 = unwrap_value (arg1);
11154  type = value_type (ada_to_fixed_value (arg1));
11155  }
11156  }
11157  else
11158  type =
11159  ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
11160  0, NULL);
11161 
11162  return value_zero (ada_aligned_type (type), lval_memory);
11163  }
11164  else
11165  arg1 = ada_value_struct_elt (arg1, &exp->elts[pc + 2].string, 0);
11166  arg1 = unwrap_value (arg1);
11167  return ada_to_fixed_value (arg1);
11168 
11169  case OP_TYPE:
11170  /* The value is not supposed to be used. This is here to make it
11171  easier to accommodate expressions that contain types. */
11172  (*pos) += 2;
11173  if (noside == EVAL_SKIP)
11174  goto nosideret;
11175  else if (noside == EVAL_AVOID_SIDE_EFFECTS)
11176  return allocate_value (exp->elts[pc + 1].type);
11177  else
11178  error (_("Attempt to use a type name as an expression"));
11179 
11180  case OP_AGGREGATE:
11181  case OP_CHOICES:
11182  case OP_OTHERS:
11183  case OP_DISCRETE_RANGE:
11184  case OP_POSITIONAL:
11185  case OP_NAME:
11186  if (noside == EVAL_NORMAL)
11187  switch (op)
11188  {
11189  case OP_NAME:
11190  error (_("Undefined name, ambiguous name, or renaming used in "
11191  "component association: %s."), &exp->elts[pc+2].string);
11192  case OP_AGGREGATE:
11193  error (_("Aggregates only allowed on the right of an assignment"));
11194  default:
11195  internal_error (__FILE__, __LINE__,
11196  _("aggregate apparently mangled"));
11197  }
11198 
11199  ada_forward_operator_length (exp, pc, &oplen, &nargs);
11200  *pos += oplen - 1;
11201  for (tem = 0; tem < nargs; tem += 1)
11202  ada_evaluate_subexp (NULL, exp, pos, noside);
11203  goto nosideret;
11204  }
11205 
11206 nosideret:
11207  return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
11208 }
11209 
11210 
11211  /* Fixed point */
11212 
11213 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
11214  type name that encodes the 'small and 'delta information.
11215  Otherwise, return NULL. */
11216 
11217 static const char *
11219 {
11220  const char *name = ada_type_name (type);
11221  enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
11222 
11223  if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
11224  {
11225  const char *tail = strstr (name, "___XF_");
11226 
11227  if (tail == NULL)
11228  return NULL;
11229  else
11230  return tail + 5;
11231  }
11232  else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
11233  return fixed_type_info (TYPE_TARGET_TYPE (type));
11234  else
11235  return NULL;
11236 }
11237 
11238 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
11239 
11240 int
11242 {
11243  return fixed_type_info (type) != NULL;
11244 }
11245 
11246 /* Return non-zero iff TYPE represents a System.Address type. */
11247 
11248 int
11250 {
11251  return (TYPE_NAME (type)
11252  && strcmp (TYPE_NAME (type), "system__address") == 0);
11253 }
11254 
11255 /* Assuming that TYPE is the representation of an Ada fixed-point
11256  type, return its delta, or -1 if the type is malformed and the
11257  delta cannot be determined. */
11258 
11259 DOUBLEST
11261 {
11262  const char *encoding = fixed_type_info (type);
11263  DOUBLEST num, den;
11264 
11265  /* Strictly speaking, num and den are encoded as integer. However,
11266  they may not fit into a long, and they will have to be converted
11267  to DOUBLEST anyway. So scan them as DOUBLEST. */
11268  if (sscanf (encoding, "_%" DOUBLEST_SCAN_FORMAT "_%" DOUBLEST_SCAN_FORMAT,
11269  &num, &den) < 2)
11270  return -1.0;
11271  else
11272  return num / den;
11273 }
11274 
11275 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
11276  factor ('SMALL value) associated with the type. */
11277 
11278 static DOUBLEST
11280 {
11281  const char *encoding = fixed_type_info (type);
11282  DOUBLEST num0, den0, num1, den1;
11283  int n;
11284 
11285  /* Strictly speaking, num's and den's are encoded as integer. However,
11286  they may not fit into a long, and they will have to be converted
11287  to DOUBLEST anyway. So scan them as DOUBLEST. */
11288  n = sscanf (encoding,
11291  &num0, &den0, &num1, &den1);
11292 
11293  if (n < 2)
11294  return 1.0;
11295  else if (n == 4)
11296  return num1 / den1;
11297  else
11298  return num0 / den0;
11299 }
11300 
11301 
11302 /* Assuming that X is the representation of a value of fixed-point
11303  type TYPE, return its floating-point equivalent. */
11304 
11305 DOUBLEST
11307 {
11308  return (DOUBLEST) x *scaling_factor (type);
11309 }
11310 
11311 /* The representation of a fixed-point value of type TYPE
11312  corresponding to the value X. */
11313 
11314 LONGEST
11316 {
11317  return (LONGEST) (x / scaling_factor (type) + 0.5);
11318 }
11319 
11320 
11321 
11322  /* Range types */
11323 
11324 /* Scan STR beginning at position K for a discriminant name, and
11325  return the value of that discriminant field of DVAL in *PX. If
11326  PNEW_K is not null, put the position of the character beyond the
11327  name scanned in *PNEW_K. Return 1 if successful; return 0 and do
11328  not alter *PX and *PNEW_K if unsuccessful. */
11329 
11330 static int
11331 scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
11332  int *pnew_k)
11333 {
11334  static char *bound_buffer = NULL;
11335  static size_t bound_buffer_len = 0;
11336  char *bound;
11337  char *pend;
11338  struct value *bound_val;
11339 
11340  if (dval == NULL || str == NULL || str[k] == '\0')
11341  return 0;
11342 
11343  pend = strstr (str + k, "__");
11344  if (pend == NULL)
11345  {
11346  bound = str + k;
11347  k += strlen (bound);
11348  }
11349  else
11350  {
11351  GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
11352  bound = bound_buffer;
11353  strncpy (bound_buffer, str + k, pend - (str + k));
11354  bound[pend - (str + k)] = '\0';
11355  k = pend - str;
11356  }
11357 
11358  bound_val = ada_search_struct_field (bound, dval, 0, value_type (dval));
11359  if (bound_val == NULL)
11360  return 0;
11361 
11362  *px = value_as_long (bound_val);
11363  if (pnew_k != NULL)
11364  *pnew_k = k;
11365  return 1;
11366 }
11367 
11368 /* Value of variable named NAME in the current environment. If
11369  no such variable found, then if ERR_MSG is null, returns 0, and
11370  otherwise causes an error with message ERR_MSG. */
11371 
11372 static struct value *
11373 get_var_value (char *name, char *err_msg)
11374 {
11375  struct ada_symbol_info *syms;
11376  int nsyms;
11377 
11379  &syms);
11380 
11381  if (nsyms != 1)
11382  {
11383  if (err_msg == NULL)
11384  return 0;
11385  else
11386  error (("%s"), err_msg);
11387  }
11388 
11389  return value_of_variable (syms[0].sym, syms[0].block);
11390 }
11391 
11392 /* Value of integer variable named NAME in the current environment. If
11393  no such variable found, returns 0, and sets *FLAG to 0. If
11394  successful, sets *FLAG to 1. */
11395 
11396 LONGEST
11397 get_int_var_value (char *name, int *flag)
11398 {
11399  struct value *var_val = get_var_value (name, 0);
11400 
11401  if (var_val == 0)
11402  {
11403  if (flag != NULL)
11404  *flag = 0;
11405  return 0;
11406  }
11407  else
11408  {
11409  if (flag != NULL)
11410  *flag = 1;
11411  return value_as_long (var_val);
11412  }
11413 }
11414 
11415 
11416 /* Return a range type whose base type is that of the range type named
11417  NAME in the current environment, and whose bounds are calculated
11418  from NAME according to the GNAT range encoding conventions.
11419  Extract discriminant values, if needed, from DVAL. ORIG_TYPE is the
11420  corresponding range type from debug information; fall back to using it
11421  if symbol lookup fails. If a new type must be created, allocate it
11422  like ORIG_TYPE was. The bounds information, in general, is encoded
11423  in NAME, the base type given in the named range type. */
11424 
11425 static struct type *
11426 to_fixed_range_type (struct type *raw_type, struct value *dval)
11427 {
11428  const char *name;
11429  struct type *base_type;
11430  char *subtype_info;
11431 
11432  gdb_assert (raw_type != NULL);
11433  gdb_assert (TYPE_NAME (raw_type) != NULL);
11434 
11435  if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
11436  base_type = TYPE_TARGET_TYPE (raw_type);
11437  else
11438  base_type = raw_type;
11439 
11440  name = TYPE_NAME (raw_type);
11441  subtype_info = strstr (name, "___XD");
11442  if (subtype_info == NULL)
11443  {
11444  LONGEST L = ada_discrete_type_low_bound (raw_type);
11445  LONGEST U = ada_discrete_type_high_bound (raw_type);
11446 
11447  if (L < INT_MIN || U > INT_MAX)
11448  return raw_type;
11449  else
11450  return create_static_range_type (alloc_type_copy (raw_type), raw_type,
11451  L, U);
11452  }
11453  else
11454  {
11455  static char *name_buf = NULL;
11456  static size_t name_len = 0;
11457  int prefix_len = subtype_info - name;
11458  LONGEST L, U;
11459  struct type *type;
11460  char *bounds_str;
11461  int n;
11462 
11463  GROW_VECT (name_buf, name_len, prefix_len + 5);
11464  strncpy (name_buf, name, prefix_len);
11465  name_buf[prefix_len] = '\0';
11466 
11467  subtype_info += 5;
11468  bounds_str = strchr (subtype_info, '_');
11469  n = 1;
11470 
11471  if (*subtype_info == 'L')
11472  {
11473  if (!ada_scan_number (bounds_str, n, &L, &n)
11474  && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
11475  return raw_type;
11476  if (bounds_str[n] == '_')
11477  n += 2;
11478  else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
11479  n += 1;
11480  subtype_info += 1;
11481  }
11482  else
11483  {
11484  int ok;
11485 
11486  strcpy (name_buf + prefix_len, "___L");
11487  L = get_int_var_value (name_buf, &ok);
11488  if (!ok)
11489  {
11490  lim_warning (_("Unknown lower bound, using 1."));
11491  L = 1;
11492  }
11493  }
11494 
11495  if (*subtype_info == 'U')
11496  {
11497  if (!ada_scan_number (bounds_str, n, &U, &n)
11498  && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
11499  return raw_type;
11500  }
11501  else
11502  {
11503  int ok;
11504 
11505  strcpy (name_buf + prefix_len, "___U");
11506  U = get_int_var_value (name_buf, &ok);
11507  if (!ok)
11508  {
11509  lim_warning (_("Unknown upper bound, using %ld."), (long) L);
11510  U = L;
11511  }
11512  }
11513 
11514  type = create_static_range_type (alloc_type_copy (raw_type),
11515  base_type, L, U);
11516  TYPE_NAME (type) = name;
11517  return type;
11518  }
11519 }
11520 
11521 /* True iff NAME is the name of a range type. */
11522 
11523 int
11525 {
11526  return (name != NULL && strstr (name, "___XD"));
11527 }
11528 
11529 
11530  /* Modular types */
11531 
11532 /* True iff TYPE is an Ada modular type. */
11533 
11534 int
11536 {
11537  struct type *subranged_type = get_base_type (type);
11538 
11539  return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
11540  && TYPE_CODE (subranged_type) == TYPE_CODE_INT
11541  && TYPE_UNSIGNED (subranged_type));
11542 }
11543 
11544 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
11545 
11546 ULONGEST
11548 {
11549  return (ULONGEST) TYPE_HIGH_BOUND (type) + 1;
11550 }
11551 
11552 
11553 /* Ada exception catchpoint support:
11554  ---------------------------------
11555 
11556  We support 3 kinds of exception catchpoints:
11557  . catchpoints on Ada exceptions
11558  . catchpoints on unhandled Ada exceptions
11559  . catchpoints on failed assertions
11560 
11561  Exceptions raised during failed assertions, or unhandled exceptions
11562  could perfectly be caught with the general catchpoint on Ada exceptions.
11563  However, we can easily differentiate these two special cases, and having
11564  the option to distinguish these two cases from the rest can be useful
11565  to zero-in on certain situations.
11566 
11567  Exception catchpoints are a specialized form of breakpoint,
11568  since they rely on inserting breakpoints inside known routines
11569  of the GNAT runtime. The implementation therefore uses a standard
11570  breakpoint structure of the BP_BREAKPOINT type, but with its own set
11571  of breakpoint_ops.
11572 
11573  Support in the runtime for exception catchpoints have been changed
11574  a few times already, and these changes affect the implementation
11575  of these catchpoints. In order to be able to support several
11576  variants of the runtime, we use a sniffer that will determine
11577  the runtime variant used by the program being debugged. */
11578 
11579 /* Ada's standard exceptions.
11580 
11581  The Ada 83 standard also defined Numeric_Error. But there so many
11582  situations where it was unclear from the Ada 83 Reference Manual
11583  (RM) whether Constraint_Error or Numeric_Error should be raised,
11584  that the ARG (Ada Rapporteur Group) eventually issued a Binding
11585  Interpretation saying that anytime the RM says that Numeric_Error
11586  should be raised, the implementation may raise Constraint_Error.
11587  Ada 95 went one step further and pretty much removed Numeric_Error
11588  from the list of standard exceptions (it made it a renaming of
11589  Constraint_Error, to help preserve compatibility when compiling
11590  an Ada83 compiler). As such, we do not include Numeric_Error from
11591  this list of standard exceptions. */
11592 
11593 static char *standard_exc[] = {
11594  "constraint_error",
11595  "program_error",
11596  "storage_error",
11597  "tasking_error"
11598 };
11599 
11601 
11602 /* A structure that describes how to support exception catchpoints
11603  for a given executable. */
11604 
11606 {
11607  /* The name of the symbol to break on in order to insert
11608  a catchpoint on exceptions. */
11609  const char *catch_exception_sym;
11610 
11611  /* The name of the symbol to break on in order to insert
11612  a catchpoint on unhandled exceptions. */
11614 
11615  /* The name of the symbol to break on in order to insert
11616  a catchpoint on failed assertions. */
11617  const char *catch_assert_sym;
11618 
11619  /* Assuming that the inferior just triggered an unhandled exception
11620  catchpoint, this function is responsible for returning the address
11621  in inferior memory where the name of that exception is stored.
11622  Return zero if the address could not be computed. */
11624 };
11625 
11628 
11629 /* The following exception support info structure describes how to
11630  implement exception catchpoints with the latest version of the
11631  Ada runtime (as of 2007-03-06). */
11632 
11633 static const struct exception_support_info default_exception_support_info =
11634 {
11635  "__gnat_debug_raise_exception", /* catch_exception_sym */
11636  "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11637  "__gnat_debug_raise_assert_failure", /* catch_assert_sym */
11639 };
11640 
11641 /* The following exception support info structure describes how to
11642  implement exception catchpoints with a slightly older version
11643  of the Ada runtime. */
11644 
11645 static const struct exception_support_info exception_support_info_fallback =
11646 {
11647  "__gnat_raise_nodefer_with_msg", /* catch_exception_sym */
11648  "__gnat_unhandled_exception", /* catch_exception_unhandled_sym */
11649  "system__assertions__raise_assert_failure", /* catch_assert_sym */
11651 };
11652 
11653 /* Return nonzero if we can detect the exception support routines
11654  described in EINFO.
11655 
11656  This function errors out if an abnormal situation is detected
11657  (for instance, if we find the exception support routines, but
11658  that support is found to be incomplete). */
11659 
11660 static int
11662 {
11663  struct symbol *sym;
11664 
11665  /* The symbol we're looking up is provided by a unit in the GNAT runtime
11666  that should be compiled with debugging information. As a result, we
11667  expect to find that symbol in the symtabs. */
11668 
11669  sym = standard_lookup (einfo->catch_exception_sym, NULL, VAR_DOMAIN);
11670  if (sym == NULL)
11671  {
11672  /* Perhaps we did not find our symbol because the Ada runtime was
11673  compiled without debugging info, or simply stripped of it.
11674  It happens on some GNU/Linux distributions for instance, where
11675  users have to install a separate debug package in order to get
11676  the runtime's debugging info. In that situation, let the user
11677  know why we cannot insert an Ada exception catchpoint.
11678 
11679  Note: Just for the purpose of inserting our Ada exception
11680  catchpoint, we could rely purely on the associated minimal symbol.
11681  But we would be operating in degraded mode anyway, since we are
11682  still lacking the debugging info needed later on to extract
11683  the name of the exception being raised (this name is printed in
11684  the catchpoint message, and is also used when trying to catch
11685  a specific exception). We do not handle this case for now. */
11686  struct bound_minimal_symbol msym
11687  = lookup_minimal_symbol (einfo->catch_exception_sym, NULL, NULL);
11688 
11689  if (msym.minsym && MSYMBOL_TYPE (msym.minsym) != mst_solib_trampoline)
11690  error (_("Your Ada runtime appears to be missing some debugging "
11691  "information.\nCannot insert Ada exception catchpoint "
11692  "in this configuration."));
11693 
11694  return 0;
11695  }
11696 
11697  /* Make sure that the symbol we found corresponds to a function. */
11698 
11699  if (SYMBOL_CLASS (sym) != LOC_BLOCK)
11700  error (_("Symbol \"%s\" is not a function (class = %d)"),
11701  SYMBOL_LINKAGE_NAME (sym), SYMBOL_CLASS (sym));
11702 
11703  return 1;
11704 }
11705 
11706 /* Inspect the Ada runtime and determine which exception info structure
11707  should be used to provide support for exception catchpoints.
11708 
11709  This function will always set the per-inferior exception_info,
11710  or raise an error. */
11711 
11712 static void
11714 {
11715  struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11716 
11717  /* If the exception info is already known, then no need to recompute it. */
11718  if (data->exception_info != NULL)
11719  return;
11720 
11721  /* Check the latest (default) exception support info. */
11722  if (ada_has_this_exception_support (&default_exception_support_info))
11723  {
11725  return;
11726  }
11727 
11728  /* Try our fallback exception suport info. */
11729  if (ada_has_this_exception_support (&exception_support_info_fallback))
11730  {
11732  return;
11733  }
11734 
11735  /* Sometimes, it is normal for us to not be able to find the routine
11736  we are looking for. This happens when the program is linked with
11737  the shared version of the GNAT runtime, and the program has not been
11738  started yet. Inform the user of these two possible causes if
11739  applicable. */
11740 
11742  error (_("Unable to insert catchpoint. Is this an Ada main program?"));
11743 
11744  /* If the symbol does not exist, then check that the program is
11745  already started, to make sure that shared libraries have been
11746  loaded. If it is not started, this may mean that the symbol is
11747  in a shared library. */
11748 
11749  if (ptid_get_pid (inferior_ptid) == 0)
11750  error (_("Unable to insert catchpoint. Try to start the program first."));
11751 
11752  /* At this point, we know that we are debugging an Ada program and
11753  that the inferior has been started, but we still are not able to
11754  find the run-time symbols. That can mean that we are in
11755  configurable run time mode, or that a-except as been optimized
11756  out by the linker... In any case, at this point it is not worth
11757  supporting this feature. */
11758 
11759  error (_("Cannot insert Ada exception catchpoints in this configuration."));
11760 }
11761 
11762 /* True iff FRAME is very likely to be that of a function that is
11763  part of the runtime system. This is all very heuristic, but is
11764  intended to be used as advice as to what frames are uninteresting
11765  to most users. */
11766 
11767 static int
11769 {
11770  struct symtab_and_line sal;
11771  char *func_name;
11772  enum language func_lang;
11773  int i;
11774  const char *fullname;
11775 
11776  /* If this code does not have any debugging information (no symtab),
11777  This cannot be any user code. */
11778 
11779  find_frame_sal (frame, &sal);
11780  if (sal.symtab == NULL)
11781  return 1;
11782 
11783  /* If there is a symtab, but the associated source file cannot be
11784  located, then assume this is not user code: Selecting a frame
11785  for which we cannot display the code would not be very helpful
11786  for the user. This should also take care of case such as VxWorks
11787  where the kernel has some debugging info provided for a few units. */
11788 
11789  fullname = symtab_to_fullname (sal.symtab);
11790  if (access (fullname, R_OK) != 0)
11791  return 1;
11792 
11793  /* Check the unit filename againt the Ada runtime file naming.
11794  We also check the name of the objfile against the name of some
11795  known system libraries that sometimes come with debugging info
11796  too. */
11797 
11798  for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
11799  {
11800  re_comp (known_runtime_file_name_patterns[i]);
11801  if (re_exec (lbasename (sal.symtab->filename)))
11802  return 1;
11803  if (SYMTAB_OBJFILE (sal.symtab) != NULL
11804  && re_exec (objfile_name (SYMTAB_OBJFILE (sal.symtab))))
11805  return 1;
11806  }
11807 
11808  /* Check whether the function is a GNAT-generated entity. */
11809 
11810  find_frame_funname (frame, &func_name, &func_lang, NULL);
11811  if (func_name == NULL)
11812  return 1;
11813 
11814  for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
11815  {
11816  re_comp (known_auxiliary_function_name_patterns[i]);
11817  if (re_exec (func_name))
11818  {
11819  xfree (func_name);
11820  return 1;
11821  }
11822  }
11823 
11824  xfree (func_name);
11825  return 0;
11826 }
11827 
11828 /* Find the first frame that contains debugging information and that is not
11829  part of the Ada run-time, starting from FI and moving upward. */
11830 
11831 void
11833 {
11834  for (; fi != NULL; fi = get_prev_frame (fi))
11835  {
11836  if (!is_known_support_routine (fi))
11837  {
11838  select_frame (fi);
11839  break;
11840  }
11841  }
11842 
11843 }
11844 
11845 /* Assuming that the inferior just triggered an unhandled exception
11846  catchpoint, return the address in inferior memory where the name
11847  of the exception is stored.
11848 
11849  Return zero if the address could not be computed. */
11850 
11851 static CORE_ADDR
11853 {
11854  return parse_and_eval_address ("e.full_name");
11855 }
11856 
11857 /* Same as ada_unhandled_exception_name_addr, except that this function
11858  should be used when the inferior uses an older version of the runtime,
11859  where the exception name needs to be extracted from a specific frame
11860  several frames up in the callstack. */
11861 
11862 static CORE_ADDR
11864 {
11865  int frame_level;
11866  struct frame_info *fi;
11867  struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11868  struct cleanup *old_chain;
11869 
11870  /* To determine the name of this exception, we need to select
11871  the frame corresponding to RAISE_SYM_NAME. This frame is
11872  at least 3 levels up, so we simply skip the first 3 frames
11873  without checking the name of their associated function. */
11874  fi = get_current_frame ();
11875  for (frame_level = 0; frame_level < 3; frame_level += 1)
11876  if (fi != NULL)
11877  fi = get_prev_frame (fi);
11878 
11879  old_chain = make_cleanup (null_cleanup, NULL);
11880  while (fi != NULL)
11881  {
11882  char *func_name;
11883  enum language func_lang;
11884 
11885  find_frame_funname (fi, &func_name, &func_lang, NULL);
11886  if (func_name != NULL)
11887  {
11888  make_cleanup (xfree, func_name);
11889 
11890  if (strcmp (func_name,
11891  data->exception_info->catch_exception_sym) == 0)
11892  break; /* We found the frame we were looking for... */
11893  fi = get_prev_frame (fi);
11894  }
11895  }
11896  do_cleanups (old_chain);
11897 
11898  if (fi == NULL)
11899  return 0;
11900 
11901  select_frame (fi);
11902  return parse_and_eval_address ("id.full_name");
11903 }
11904 
11905 /* Assuming the inferior just triggered an Ada exception catchpoint
11906  (of any type), return the address in inferior memory where the name
11907  of the exception is stored, if applicable.
11908 
11909  Return zero if the address could not be computed, or if not relevant. */
11910 
11911 static CORE_ADDR
11913  struct breakpoint *b)
11914 {
11915  struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
11916 
11917  switch (ex)
11918  {
11919  case ada_catch_exception:
11920  return (parse_and_eval_address ("e.full_name"));
11921  break;
11922 
11925  break;
11926 
11927  case ada_catch_assert:
11928  return 0; /* Exception name is not relevant in this case. */
11929  break;
11930 
11931  default:
11932  internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
11933  break;
11934  }
11935 
11936  return 0; /* Should never be reached. */
11937 }
11938 
11939 /* Same as ada_exception_name_addr_1, except that it intercepts and contains
11940  any error that ada_exception_name_addr_1 might cause to be thrown.
11941  When an error is intercepted, a warning with the error message is printed,
11942  and zero is returned. */
11943 
11944 static CORE_ADDR
11946  struct breakpoint *b)
11947 {
11948  CORE_ADDR result = 0;
11949 
11950  TRY
11951  {
11952  result = ada_exception_name_addr_1 (ex, b);
11953  }
11954 
11956  {
11957  warning (_("failed to get exception name: %s"), e.message);
11958  return 0;
11959  }
11960  END_CATCH
11961 
11962  return result;
11963 }
11964 
11965 static char *ada_exception_catchpoint_cond_string (const char *excep_string);
11966 
11967 /* Ada catchpoints.
11968 
11969  In the case of catchpoints on Ada exceptions, the catchpoint will
11970  stop the target on every exception the program throws. When a user
11971  specifies the name of a specific exception, we translate this
11972  request into a condition expression (in text form), and then parse
11973  it into an expression stored in each of the catchpoint's locations.
11974  We then use this condition to check whether the exception that was
11975  raised is the one the user is interested in. If not, then the
11976  target is resumed again. We store the name of the requested
11977  exception, in order to be able to re-set the condition expression
11978  when symbols change. */
11979 
11980 /* An instance of this type is used to represent an Ada catchpoint
11981  breakpoint location. It includes a "struct bp_location" as a kind
11982  of base class; users downcast to "struct bp_location *" when
11983  needed. */
11984 
11986 {
11987  /* The base class. */
11989 
11990  /* The condition that checks whether the exception that was raised
11991  is the specific exception the user specified on catchpoint
11992  creation. */
11994 };
11995 
11996 /* Implement the DTOR method in the bp_location_ops structure for all
11997  Ada exception catchpoint kinds. */
11998 
11999 static void
12001 {
12002  struct ada_catchpoint_location *al = (struct ada_catchpoint_location *) bl;
12003 
12004  xfree (al->excep_cond_expr);
12005 }
12006 
12007 /* The vtable to be used in Ada catchpoint locations. */
12008 
12009 static const struct bp_location_ops ada_catchpoint_location_ops =
12010 {
12012 };
12013 
12014 /* An instance of this type is used to represent an Ada catchpoint.
12015  It includes a "struct breakpoint" as a kind of base class; users
12016  downcast to "struct breakpoint *" when needed. */
12017 
12019 {
12020  /* The base class. */
12022 
12023  /* The name of the specific exception the user specified. */
12025 };
12026 
12027 /* Parse the exception condition string in the context of each of the
12028  catchpoint's locations, and store them for later evaluation. */
12029 
12030 static void
12032 {
12033  struct cleanup *old_chain;
12034  struct bp_location *bl;
12035  char *cond_string;
12036 
12037  /* Nothing to do if there's no specific exception to catch. */
12038  if (c->excep_string == NULL)
12039  return;
12040 
12041  /* Same if there are no locations... */
12042  if (c->base.loc == NULL)
12043  return;
12044 
12045  /* Compute the condition expression in text form, from the specific
12046  expection we want to catch. */
12048  old_chain = make_cleanup (xfree, cond_string);
12049 
12050  /* Iterate over all the catchpoint's locations, and parse an
12051  expression for each. */
12052  for (bl = c->base.loc; bl != NULL; bl = bl->next)
12053  {
12054  struct ada_catchpoint_location *ada_loc
12055  = (struct ada_catchpoint_location *) bl;
12056  struct expression *exp = NULL;
12057 
12058  if (!bl->shlib_disabled)
12059  {
12060  const char *s;
12061 
12062  s = cond_string;
12063  TRY
12064  {
12065  exp = parse_exp_1 (&s, bl->address,
12066  block_for_pc (bl->address), 0);
12067  }
12069  {
12070  warning (_("failed to reevaluate internal exception condition "
12071  "for catchpoint %d: %s"),
12072  c->base.number, e.message);
12073  /* There is a bug in GCC on sparc-solaris when building with
12074  optimization which causes EXP to change unexpectedly
12075  (http://gcc.gnu.org/bugzilla/show_bug.cgi?id=56982).
12076  The problem should be fixed starting with GCC 4.9.
12077  In the meantime, work around it by forcing EXP back
12078  to NULL. */
12079  exp = NULL;
12080  }
12081  END_CATCH
12082  }
12083 
12084  ada_loc->excep_cond_expr = exp;
12085  }
12086 
12087  do_cleanups (old_chain);
12088 }
12089 
12090 /* Implement the DTOR method in the breakpoint_ops structure for all
12091  exception catchpoint kinds. */
12092 
12093 static void
12095 {
12096  struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12097 
12098  xfree (c->excep_string);
12099 
12101 }
12102 
12103 /* Implement the ALLOCATE_LOCATION method in the breakpoint_ops
12104  structure for all exception catchpoint kinds. */
12105 
12106 static struct bp_location *
12108  struct breakpoint *self)
12109 {
12110  struct ada_catchpoint_location *loc;
12111 
12112  loc = XNEW (struct ada_catchpoint_location);
12113  init_bp_location (&loc->base, &ada_catchpoint_location_ops, self);
12114  loc->excep_cond_expr = NULL;
12115  return &loc->base;
12116 }
12117 
12118 /* Implement the RE_SET method in the breakpoint_ops structure for all
12119  exception catchpoint kinds. */
12120 
12121 static void
12123 {
12124  struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12125 
12126  /* Call the base class's method. This updates the catchpoint's
12127  locations. */
12129 
12130  /* Reparse the exception conditional expressions. One for each
12131  location. */
12133 }
12134 
12135 /* Returns true if we should stop for this breakpoint hit. If the
12136  user specified a specific exception, we only want to cause a stop
12137  if the program thrown that exception. */
12138 
12139 static int
12141 {
12142  struct ada_catchpoint *c = (struct ada_catchpoint *) bl->owner;
12143  const struct ada_catchpoint_location *ada_loc
12144  = (const struct ada_catchpoint_location *) bl;
12145  int stop;
12146 
12147  /* With no specific exception, should always stop. */
12148  if (c->excep_string == NULL)
12149  return 1;
12150 
12151  if (ada_loc->excep_cond_expr == NULL)
12152  {
12153  /* We will have a NULL expression if back when we were creating
12154  the expressions, this location's had failed to parse. */
12155  return 1;
12156  }
12157 
12158  stop = 1;
12159  TRY
12160  {
12161  struct value *mark;
12162 
12163  mark = value_mark ();
12164  stop = value_true (evaluate_expression (ada_loc->excep_cond_expr));
12165  value_free_to_mark (mark);
12166  }
12167  CATCH (ex, RETURN_MASK_ALL)
12168  {
12170  _("Error in testing exception condition:\n"));
12171  }
12172  END_CATCH
12173 
12174  return stop;
12175 }
12176 
12177 /* Implement the CHECK_STATUS method in the breakpoint_ops structure
12178  for all exception catchpoint kinds. */
12179 
12180 static void
12182 {
12184 }
12185 
12186 /* Implement the PRINT_IT method in the breakpoint_ops structure
12187  for all exception catchpoint kinds. */
12188 
12189 static enum print_stop_action
12191 {
12192  struct ui_out *uiout = current_uiout;
12193  struct breakpoint *b = bs->breakpoint_at;
12194 
12196 
12197  if (ui_out_is_mi_like_p (uiout))
12198  {
12199  ui_out_field_string (uiout, "reason",
12201  ui_out_field_string (uiout, "disp", bpdisp_text (b->disposition));
12202  }
12203 
12204  ui_out_text (uiout,
12205  b->disposition == disp_del ? "\nTemporary catchpoint "
12206  : "\nCatchpoint ");
12207  ui_out_field_int (uiout, "bkptno", b->number);
12208  ui_out_text (uiout, ", ");
12209 
12210  switch (ex)
12211  {
12212  case ada_catch_exception:
12214  {
12215  const CORE_ADDR addr = ada_exception_name_addr (ex, b);
12216  char exception_name[256];
12217 
12218  if (addr != 0)
12219  {
12220  read_memory (addr, (gdb_byte *) exception_name,
12221  sizeof (exception_name) - 1);
12222  exception_name [sizeof (exception_name) - 1] = '\0';
12223  }
12224  else
12225  {
12226  /* For some reason, we were unable to read the exception
12227  name. This could happen if the Runtime was compiled
12228  without debugging info, for instance. In that case,
12229  just replace the exception name by the generic string
12230  "exception" - it will read as "an exception" in the
12231  notification we are about to print. */
12232  memcpy (exception_name, "exception", sizeof ("exception"));
12233  }
12234  /* In the case of unhandled exception breakpoints, we print
12235  the exception name as "unhandled EXCEPTION_NAME", to make
12236  it clearer to the user which kind of catchpoint just got
12237  hit. We used ui_out_text to make sure that this extra
12238  info does not pollute the exception name in the MI case. */
12240  ui_out_text (uiout, "unhandled ");
12241  ui_out_field_string (uiout, "exception-name", exception_name);
12242  }
12243  break;
12244  case ada_catch_assert:
12245  /* In this case, the name of the exception is not really
12246  important. Just print "failed assertion" to make it clearer
12247  that his program just hit an assertion-failure catchpoint.
12248  We used ui_out_text because this info does not belong in
12249  the MI output. */
12250  ui_out_text (uiout, "failed assertion");
12251  break;
12252  }
12253  ui_out_text (uiout, " at ");
12255 
12256  return PRINT_SRC_AND_LOC;
12257 }
12258 
12259 /* Implement the PRINT_ONE method in the breakpoint_ops structure
12260  for all exception catchpoint kinds. */
12261 
12262 static void
12264  struct breakpoint *b, struct bp_location **last_loc)
12265 {
12266  struct ui_out *uiout = current_uiout;
12267  struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12268  struct value_print_options opts;
12269 
12270  get_user_print_options (&opts);
12271  if (opts.addressprint)
12272  {
12273  annotate_field (4);
12274  ui_out_field_core_addr (uiout, "addr", b->loc->gdbarch, b->loc->address);
12275  }
12276 
12277  annotate_field (5);
12278  *last_loc = b->loc;
12279  switch (ex)
12280  {
12281  case ada_catch_exception:
12282  if (c->excep_string != NULL)
12283  {
12284  char *msg = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12285 
12286  ui_out_field_string (uiout, "what", msg);
12287  xfree (msg);
12288  }
12289  else
12290  ui_out_field_string (uiout, "what", "all Ada exceptions");
12291 
12292  break;
12293 
12295  ui_out_field_string (uiout, "what", "unhandled Ada exceptions");
12296  break;
12297 
12298  case ada_catch_assert:
12299  ui_out_field_string (uiout, "what", "failed Ada assertions");
12300  break;
12301 
12302  default:
12303  internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12304  break;
12305  }
12306 }
12307 
12308 /* Implement the PRINT_MENTION method in the breakpoint_ops structure
12309  for all exception catchpoint kinds. */
12310 
12311 static void
12313  struct breakpoint *b)
12314 {
12315  struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12316  struct ui_out *uiout = current_uiout;
12317 
12318  ui_out_text (uiout, b->disposition == disp_del ? _("Temporary catchpoint ")
12319  : _("Catchpoint "));
12320  ui_out_field_int (uiout, "bkptno", b->number);
12321  ui_out_text (uiout, ": ");
12322 
12323  switch (ex)
12324  {
12325  case ada_catch_exception:
12326  if (c->excep_string != NULL)
12327  {
12328  char *info = xstrprintf (_("`%s' Ada exception"), c->excep_string);
12329  struct cleanup *old_chain = make_cleanup (xfree, info);
12330 
12331  ui_out_text (uiout, info);
12332  do_cleanups (old_chain);
12333  }
12334  else
12335  ui_out_text (uiout, _("all Ada exceptions"));
12336  break;
12337 
12339  ui_out_text (uiout, _("unhandled Ada exceptions"));
12340  break;
12341 
12342  case ada_catch_assert:
12343  ui_out_text (uiout, _("failed Ada assertions"));
12344  break;
12345 
12346  default:
12347  internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12348  break;
12349  }
12350 }
12351 
12352 /* Implement the PRINT_RECREATE method in the breakpoint_ops structure
12353  for all exception catchpoint kinds. */
12354 
12355 static void
12357  struct breakpoint *b, struct ui_file *fp)
12358 {
12359  struct ada_catchpoint *c = (struct ada_catchpoint *) b;
12360 
12361  switch (ex)
12362  {
12363  case ada_catch_exception:
12364  fprintf_filtered (fp, "catch exception");
12365  if (c->excep_string != NULL)
12366  fprintf_filtered (fp, " %s", c->excep_string);
12367  break;
12368 
12370  fprintf_filtered (fp, "catch exception unhandled");
12371  break;
12372 
12373  case ada_catch_assert:
12374  fprintf_filtered (fp, "catch assert");
12375  break;
12376 
12377  default:
12378  internal_error (__FILE__, __LINE__, _("unexpected catchpoint type"));
12379  }
12380  print_recreate_thread (b, fp);
12381 }
12382 
12383 /* Virtual table for "catch exception" breakpoints. */
12384 
12385 static void
12387 {
12389 }
12390 
12391 static struct bp_location *
12393 {
12395 }
12396 
12397 static void
12399 {
12401 }
12402 
12403 static void
12405 {
12407 }
12408 
12409 static enum print_stop_action
12411 {
12413 }
12414 
12415 static void
12416 print_one_catch_exception (struct breakpoint *b, struct bp_location **last_loc)
12417 {
12419 }
12420 
12421 static void
12423 {
12425 }
12426 
12427 static void
12429 {
12431 }
12432 
12434 
12435 /* Virtual table for "catch exception unhandled" breakpoints. */
12436 
12437 static void
12439 {
12441 }
12442 
12443 static struct bp_location *
12445 {
12447 }
12448 
12449 static void
12451 {
12453 }
12454 
12455 static void
12457 {
12459 }
12460 
12461 static enum print_stop_action
12463 {
12465 }
12466 
12467 static void
12469  struct bp_location **last_loc)
12470 {
12472 }
12473 
12474 static void
12476 {
12478 }
12479 
12480 static void
12482  struct ui_file *fp)
12483 {
12485 }
12486 
12488 
12489 /* Virtual table for "catch assert" breakpoints. */
12490 
12491 static void
12493 {
12495 }
12496 
12497 static struct bp_location *
12499 {
12501 }
12502 
12503 static void
12505 {
12507 }
12508 
12509 static void
12511 {
12513 }
12514 
12515 static enum print_stop_action
12517 {
12518  return print_it_exception (ada_catch_assert, bs);
12519 }
12520 
12521 static void
12522 print_one_catch_assert (struct breakpoint *b, struct bp_location **last_loc)
12523 {
12524  print_one_exception (ada_catch_assert, b, last_loc);
12525 }
12526 
12527 static void
12529 {
12531 }
12532 
12533 static void
12535 {
12537 }
12538 
12540 
12541 /* Return a newly allocated copy of the first space-separated token
12542  in ARGSP, and then adjust ARGSP to point immediately after that
12543  token.
12544 
12545  Return NULL if ARGPS does not contain any more tokens. */
12546 
12547 static char *
12548 ada_get_next_arg (char **argsp)
12549 {
12550  char *args = *argsp;
12551  char *end;
12552  char *result;
12553 
12554  args = skip_spaces (args);
12555  if (args[0] == '\0')
12556  return NULL; /* No more arguments. */
12557 
12558  /* Find the end of the current argument. */
12559 
12560  end = skip_to_space (args);
12561 
12562  /* Adjust ARGSP to point to the start of the next argument. */
12563 
12564  *argsp = end;
12565 
12566  /* Make a copy of the current argument and return it. */
12567 
12568  result = xmalloc (end - args + 1);
12569  strncpy (result, args, end - args);
12570  result[end - args] = '\0';
12571 
12572  return result;
12573 }
12574 
12575 /* Split the arguments specified in a "catch exception" command.
12576  Set EX to the appropriate catchpoint type.
12577  Set EXCEP_STRING to the name of the specific exception if
12578  specified by the user.
12579  If a condition is found at the end of the arguments, the condition
12580  expression is stored in COND_STRING (memory must be deallocated
12581  after use). Otherwise COND_STRING is set to NULL. */
12582 
12583 static void
12586  char **excep_string,
12587  char **cond_string)
12588 {
12589  struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
12590  char *exception_name;
12591  char *cond = NULL;
12592 
12593  exception_name = ada_get_next_arg (&args);
12594  if (exception_name != NULL && strcmp (exception_name, "if") == 0)
12595  {
12596  /* This is not an exception name; this is the start of a condition
12597  expression for a catchpoint on all exceptions. So, "un-get"
12598  this token, and set exception_name to NULL. */
12599  xfree (exception_name);
12600  exception_name = NULL;
12601  args -= 2;
12602  }
12603  make_cleanup (xfree, exception_name);
12604 
12605  /* Check to see if we have a condition. */
12606 
12607  args = skip_spaces (args);
12608  if (startswith (args, "if")
12609  && (isspace (args[2]) || args[2] == '\0'))
12610  {
12611  args += 2;
12612  args = skip_spaces (args);
12613 
12614  if (args[0] == '\0')
12615  error (_("Condition missing after `if' keyword"));
12616  cond = xstrdup (args);
12617  make_cleanup (xfree, cond);
12618 
12619  args += strlen (args);
12620  }
12621 
12622  /* Check that we do not have any more arguments. Anything else
12623  is unexpected. */
12624 
12625  if (args[0] != '\0')
12626  error (_("Junk at end of expression"));
12627 
12628  discard_cleanups (old_chain);
12629 
12630  if (exception_name == NULL)
12631  {
12632  /* Catch all exceptions. */
12633  *ex = ada_catch_exception;
12634  *excep_string = NULL;
12635  }
12636  else if (strcmp (exception_name, "unhandled") == 0)
12637  {
12638  /* Catch unhandled exceptions. */
12640  *excep_string = NULL;
12641  }
12642  else
12643  {
12644  /* Catch a specific exception. */
12645  *ex = ada_catch_exception;
12646  *excep_string = exception_name;
12647  }
12648  *cond_string = cond;
12649 }
12650 
12651 /* Return the name of the symbol on which we should break in order to
12652  implement a catchpoint of the EX kind. */
12653 
12654 static const char *
12656 {
12657  struct ada_inferior_data *data = get_ada_inferior_data (current_inferior ());
12658 
12659  gdb_assert (data->exception_info != NULL);
12660 
12661  switch (ex)
12662  {
12663  case ada_catch_exception:
12664  return (data->exception_info->catch_exception_sym);
12665  break;
12668  break;
12669  case ada_catch_assert:
12670  return (data->exception_info->catch_assert_sym);
12671  break;
12672  default:
12673  internal_error (__FILE__, __LINE__,
12674  _("unexpected catchpoint kind (%d)"), ex);
12675  }
12676 }
12677 
12678 /* Return the breakpoint ops "virtual table" used for catchpoints
12679  of the EX kind. */
12680 
12681 static const struct breakpoint_ops *
12683 {
12684  switch (ex)
12685  {
12686  case ada_catch_exception:
12688  break;
12691  break;
12692  case ada_catch_assert:
12693  return (&catch_assert_breakpoint_ops);
12694  break;
12695  default:
12696  internal_error (__FILE__, __LINE__,
12697  _("unexpected catchpoint kind (%d)"), ex);
12698  }
12699 }
12700 
12701 /* Return the condition that will be used to match the current exception
12702  being raised with the exception that the user wants to catch. This
12703  assumes that this condition is used when the inferior just triggered
12704  an exception catchpoint.
12705 
12706  The string returned is a newly allocated string that needs to be
12707  deallocated later. */
12708 
12709 static char *
12710 ada_exception_catchpoint_cond_string (const char *excep_string)
12711 {
12712  int i;
12713 
12714  /* The standard exceptions are a special case. They are defined in
12715  runtime units that have been compiled without debugging info; if
12716  EXCEP_STRING is the not-fully-qualified name of a standard
12717  exception (e.g. "constraint_error") then, during the evaluation
12718  of the condition expression, the symbol lookup on this name would
12719  *not* return this standard exception. The catchpoint condition
12720  may then be set only on user-defined exceptions which have the
12721  same not-fully-qualified name (e.g. my_package.constraint_error).
12722 
12723  To avoid this unexcepted behavior, these standard exceptions are
12724  systematically prefixed by "standard". This means that "catch
12725  exception constraint_error" is rewritten into "catch exception
12726  standard.constraint_error".
12727 
12728  If an exception named contraint_error is defined in another package of
12729  the inferior program, then the only way to specify this exception as a
12730  breakpoint condition is to use its fully-qualified named:
12731  e.g. my_package.constraint_error. */
12732 
12733  for (i = 0; i < sizeof (standard_exc) / sizeof (char *); i++)
12734  {
12735  if (strcmp (standard_exc [i], excep_string) == 0)
12736  {
12737  return xstrprintf ("long_integer (e) = long_integer (&standard.%s)",
12738  excep_string);
12739  }
12740  }
12741  return xstrprintf ("long_integer (e) = long_integer (&%s)", excep_string);
12742 }
12743 
12744 /* Return the symtab_and_line that should be used to insert an exception
12745  catchpoint of the TYPE kind.
12746 
12747  EXCEP_STRING should contain the name of a specific exception that
12748  the catchpoint should catch, or NULL otherwise.
12749 
12750  ADDR_STRING returns the name of the function where the real
12751  breakpoint that implements the catchpoints is set, depending on the
12752  type of catchpoint we need to create. */
12753 
12754 static struct symtab_and_line
12756  char **addr_string, const struct breakpoint_ops **ops)
12757 {
12758  const char *sym_name;
12759  struct symbol *sym;
12760 
12761  /* First, find out which exception support info to use. */
12763 
12764  /* Then lookup the function on which we will break in order to catch
12765  the Ada exceptions requested by the user. */
12766  sym_name = ada_exception_sym_name (ex);
12767  sym = standard_lookup (sym_name, NULL, VAR_DOMAIN);
12768 
12769  /* We can assume that SYM is not NULL at this stage. If the symbol
12770  did not exist, ada_exception_support_info_sniffer would have
12771  raised an exception.
12772 
12773  Also, ada_exception_support_info_sniffer should have already
12774  verified that SYM is a function symbol. */
12775  gdb_assert (sym != NULL);
12776  gdb_assert (SYMBOL_CLASS (sym) == LOC_BLOCK);
12777 
12778  /* Set ADDR_STRING. */
12779  *addr_string = xstrdup (sym_name);
12780 
12781  /* Set OPS. */
12782  *ops = ada_exception_breakpoint_ops (ex);
12783 
12784  return find_function_start_sal (sym, 1);
12785 }
12786 
12787 /* Create an Ada exception catchpoint.
12788 
12789  EX_KIND is the kind of exception catchpoint to be created.
12790 
12791  If EXCEPT_STRING is NULL, this catchpoint is expected to trigger
12792  for all exceptions. Otherwise, EXCEPT_STRING indicates the name
12793  of the exception to which this catchpoint applies. When not NULL,
12794  the string must be allocated on the heap, and its deallocation
12795  is no longer the responsibility of the caller.
12796 
12797  COND_STRING, if not NULL, is the catchpoint condition. This string
12798  must be allocated on the heap, and its deallocation is no longer
12799  the responsibility of the caller.
12800 
12801  TEMPFLAG, if nonzero, means that the underlying breakpoint
12802  should be temporary.
12803 
12804  FROM_TTY is the usual argument passed to all commands implementations. */
12805 
12806 void
12808  enum ada_exception_catchpoint_kind ex_kind,
12809  char *excep_string,
12810  char *cond_string,
12811  int tempflag,
12812  int disabled,
12813  int from_tty)
12814 {
12815  struct ada_catchpoint *c;
12816  char *addr_string = NULL;
12817  const struct breakpoint_ops *ops = NULL;
12818  struct symtab_and_line sal
12819  = ada_exception_sal (ex_kind, excep_string, &addr_string, &ops);
12820 
12821  c = XNEW (struct ada_catchpoint);
12822  init_ada_exception_breakpoint (&c->base, gdbarch, sal, addr_string,
12823  ops, tempflag, disabled, from_tty);
12824  c->excep_string = excep_string;
12826  if (cond_string != NULL)
12827  set_breakpoint_condition (&c->base, cond_string, from_tty);
12828  install_breakpoint (0, &c->base, 1);
12829 }
12830 
12831 /* Implement the "catch exception" command. */
12832 
12833 static void
12834 catch_ada_exception_command (char *arg, int from_tty,
12835  struct cmd_list_element *command)
12836 {
12837  struct gdbarch *gdbarch = get_current_arch ();
12838  int tempflag;
12839  enum ada_exception_catchpoint_kind ex_kind;
12840  char *excep_string = NULL;
12841  char *cond_string = NULL;
12842 
12843  tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12844 
12845  if (!arg)
12846  arg = "";
12847  catch_ada_exception_command_split (arg, &ex_kind, &excep_string,
12848  &cond_string);
12849  create_ada_exception_catchpoint (gdbarch, ex_kind,
12850  excep_string, cond_string,
12851  tempflag, 1 /* enabled */,
12852  from_tty);
12853 }
12854 
12855 /* Split the arguments specified in a "catch assert" command.
12856 
12857  ARGS contains the command's arguments (or the empty string if
12858  no arguments were passed).
12859 
12860  If ARGS contains a condition, set COND_STRING to that condition
12861  (the memory needs to be deallocated after use). */
12862 
12863 static void
12864 catch_ada_assert_command_split (char *args, char **cond_string)
12865 {
12866  args = skip_spaces (args);
12867 
12868  /* Check whether a condition was provided. */
12869  if (startswith (args, "if")
12870  && (isspace (args[2]) || args[2] == '\0'))
12871  {
12872  args += 2;
12873  args = skip_spaces (args);
12874  if (args[0] == '\0')
12875  error (_("condition missing after `if' keyword"));
12876  *cond_string = xstrdup (args);
12877  }
12878 
12879  /* Otherwise, there should be no other argument at the end of
12880  the command. */
12881  else if (args[0] != '\0')
12882  error (_("Junk at end of arguments."));
12883 }
12884 
12885 /* Implement the "catch assert" command. */
12886 
12887 static void
12888 catch_assert_command (char *arg, int from_tty,
12889  struct cmd_list_element *command)
12890 {
12891  struct gdbarch *gdbarch = get_current_arch ();
12892  int tempflag;
12893  char *cond_string = NULL;
12894 
12895  tempflag = get_cmd_context (command) == CATCH_TEMPORARY;
12896 
12897  if (!arg)
12898  arg = "";
12899  catch_ada_assert_command_split (arg, &cond_string);
12901  NULL, cond_string,
12902  tempflag, 1 /* enabled */,
12903  from_tty);
12904 }
12905 
12906 /* Return non-zero if the symbol SYM is an Ada exception object. */
12907 
12908 static int
12910 {
12911  const char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
12912 
12913  return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
12914  && SYMBOL_CLASS (sym) != LOC_BLOCK
12915  && SYMBOL_CLASS (sym) != LOC_CONST
12916  && SYMBOL_CLASS (sym) != LOC_UNRESOLVED
12917  && type_name != NULL && strcmp (type_name, "exception") == 0);
12918 }
12919 
12920 /* Given a global symbol SYM, return non-zero iff SYM is a non-standard
12921  Ada exception object. This matches all exceptions except the ones
12922  defined by the Ada language. */
12923 
12924 static int
12926 {
12927  int i;
12928 
12929  if (!ada_is_exception_sym (sym))
12930  return 0;
12931 
12932  for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
12933  if (strcmp (SYMBOL_LINKAGE_NAME (sym), standard_exc[i]) == 0)
12934  return 0; /* A standard exception. */
12935 
12936  /* Numeric_Error is also a standard exception, so exclude it.
12937  See the STANDARD_EXC description for more details as to why
12938  this exception is not listed in that array. */
12939  if (strcmp (SYMBOL_LINKAGE_NAME (sym), "numeric_error") == 0)
12940  return 0;
12941 
12942  return 1;
12943 }
12944 
12945 /* A helper function for qsort, comparing two struct ada_exc_info
12946  objects.
12947 
12948  The comparison is determined first by exception name, and then
12949  by exception address. */
12950 
12951 static int
12952 compare_ada_exception_info (const void *a, const void *b)
12953 {
12954  const struct ada_exc_info *exc_a = (struct ada_exc_info *) a;
12955  const struct ada_exc_info *exc_b = (struct ada_exc_info *) b;
12956  int result;
12957 
12958  result = strcmp (exc_a->name, exc_b->name);
12959  if (result != 0)
12960  return result;
12961 
12962  if (exc_a->addr < exc_b->addr)
12963  return -1;
12964  if (exc_a->addr > exc_b->addr)
12965  return 1;
12966 
12967  return 0;
12968 }
12969 
12970 /* Sort EXCEPTIONS using compare_ada_exception_info as the comparison
12971  routine, but keeping the first SKIP elements untouched.
12972 
12973  All duplicates are also removed. */
12974 
12975 static void
12977  int skip)
12978 {
12979  struct ada_exc_info *to_sort
12980  = VEC_address (ada_exc_info, *exceptions) + skip;
12981  int to_sort_len
12982  = VEC_length (ada_exc_info, *exceptions) - skip;
12983  int i, j;
12984 
12985  qsort (to_sort, to_sort_len, sizeof (struct ada_exc_info),
12987 
12988  for (i = 1, j = 1; i < to_sort_len; i++)
12989  if (compare_ada_exception_info (&to_sort[i], &to_sort[j - 1]) != 0)
12990  to_sort[j++] = to_sort[i];
12991  to_sort_len = j;
12992  VEC_truncate(ada_exc_info, *exceptions, skip + to_sort_len);
12993 }
12994 
12995 /* A function intended as the "name_matcher" callback in the struct
12996  quick_symbol_functions' expand_symtabs_matching method.
12997 
12998  SEARCH_NAME is the symbol's search name.
12999 
13000  If USER_DATA is not NULL, it is a pointer to a regext_t object
13001  used to match the symbol (by natural name). Otherwise, when USER_DATA
13002  is null, no filtering is performed, and all symbols are a positive
13003  match. */
13004 
13005 static int
13006 ada_exc_search_name_matches (const char *search_name, void *user_data)
13007 {
13008  regex_t *preg = user_data;
13009 
13010  if (preg == NULL)
13011  return 1;
13012 
13013  /* In Ada, the symbol "search name" is a linkage name, whereas
13014  the regular expression used to do the matching refers to
13015  the natural name. So match against the decoded name. */
13016  return (regexec (preg, ada_decode (search_name), 0, NULL, 0) == 0);
13017 }
13018 
13019 /* Add all exceptions defined by the Ada standard whose name match
13020  a regular expression.
13021 
13022  If PREG is not NULL, then this regexp_t object is used to
13023  perform the symbol name matching. Otherwise, no name-based
13024  filtering is performed.
13025 
13026  EXCEPTIONS is a vector of exceptions to which matching exceptions
13027  gets pushed. */
13028 
13029 static void
13030 ada_add_standard_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
13031 {
13032  int i;
13033 
13034  for (i = 0; i < ARRAY_SIZE (standard_exc); i++)
13035  {
13036  if (preg == NULL
13037  || regexec (preg, standard_exc[i], 0, NULL, 0) == 0)
13038  {
13039  struct bound_minimal_symbol msymbol
13040  = ada_lookup_simple_minsym (standard_exc[i]);
13041 
13042  if (msymbol.minsym != NULL)
13043  {
13044  struct ada_exc_info info
13045  = {standard_exc[i], BMSYMBOL_VALUE_ADDRESS (msymbol)};
13046 
13047  VEC_safe_push (ada_exc_info, *exceptions, &info);
13048  }
13049  }
13050  }
13051 }
13052 
13053 /* Add all Ada exceptions defined locally and accessible from the given
13054  FRAME.
13055 
13056  If PREG is not NULL, then this regexp_t object is used to
13057  perform the symbol name matching. Otherwise, no name-based
13058  filtering is performed.
13059 
13060  EXCEPTIONS is a vector of exceptions to which matching exceptions
13061  gets pushed. */
13062 
13063 static void
13064 ada_add_exceptions_from_frame (regex_t *preg, struct frame_info *frame,
13065  VEC(ada_exc_info) **exceptions)
13066 {
13067  const struct block *block = get_frame_block (frame, 0);
13068 
13069  while (block != 0)
13070  {
13071  struct block_iterator iter;
13072  struct symbol *sym;
13073 
13074  ALL_BLOCK_SYMBOLS (block, iter, sym)
13075  {
13076  switch (SYMBOL_CLASS (sym))
13077  {
13078  case LOC_TYPEDEF:
13079  case LOC_BLOCK:
13080  case LOC_CONST:
13081  break;
13082  default:
13083  if (ada_is_exception_sym (sym))
13084  {
13085  struct ada_exc_info info = {SYMBOL_PRINT_NAME (sym),
13086  SYMBOL_VALUE_ADDRESS (sym)};
13087 
13088  VEC_safe_push (ada_exc_info, *exceptions, &info);
13089  }
13090  }
13091  }
13092  if (BLOCK_FUNCTION (block) != NULL)
13093  break;
13094  block = BLOCK_SUPERBLOCK (block);
13095  }
13096 }
13097 
13098 /* Add all exceptions defined globally whose name name match
13099  a regular expression, excluding standard exceptions.
13100 
13101  The reason we exclude standard exceptions is that they need
13102  to be handled separately: Standard exceptions are defined inside
13103  a runtime unit which is normally not compiled with debugging info,
13104  and thus usually do not show up in our symbol search. However,
13105  if the unit was in fact built with debugging info, we need to
13106  exclude them because they would duplicate the entry we found
13107  during the special loop that specifically searches for those
13108  standard exceptions.
13109 
13110  If PREG is not NULL, then this regexp_t object is used to
13111  perform the symbol name matching. Otherwise, no name-based
13112  filtering is performed.
13113 
13114  EXCEPTIONS is a vector of exceptions to which matching exceptions
13115  gets pushed. */
13116 
13117 static void
13118 ada_add_global_exceptions (regex_t *preg, VEC(ada_exc_info) **exceptions)
13119 {
13120  struct objfile *objfile;
13121  struct compunit_symtab *s;
13122 
13124  VARIABLES_DOMAIN, preg);
13125 
13126  ALL_COMPUNITS (objfile, s)
13127  {
13128  const struct blockvector *bv = COMPUNIT_BLOCKVECTOR (s);
13129  int i;
13130 
13131  for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
13132  {
13133  struct block *b = BLOCKVECTOR_BLOCK (bv, i);
13134  struct block_iterator iter;
13135  struct symbol *sym;
13136 
13137  ALL_BLOCK_SYMBOLS (b, iter, sym)
13139  && (preg == NULL
13140  || regexec (preg, SYMBOL_NATURAL_NAME (sym),
13141  0, NULL, 0) == 0))
13142  {
13143  struct ada_exc_info info
13144  = {SYMBOL_PRINT_NAME (sym), SYMBOL_VALUE_ADDRESS (sym)};
13145 
13146  VEC_safe_push (ada_exc_info, *exceptions, &info);
13147  }
13148  }
13149  }
13150 }
13151 
13152 /* Implements ada_exceptions_list with the regular expression passed
13153  as a regex_t, rather than a string.
13154 
13155  If not NULL, PREG is used to filter out exceptions whose names
13156  do not match. Otherwise, all exceptions are listed. */
13157 
13159 ada_exceptions_list_1 (regex_t *preg)
13160 {
13161  VEC(ada_exc_info) *result = NULL;
13162  struct cleanup *old_chain
13163  = make_cleanup (VEC_cleanup (ada_exc_info), &result);
13164  int prev_len;
13165 
13166  /* First, list the known standard exceptions. These exceptions
13167  need to be handled separately, as they are usually defined in
13168  runtime units that have been compiled without debugging info. */
13169 
13170  ada_add_standard_exceptions (preg, &result);
13171 
13172  /* Next, find all exceptions whose scope is local and accessible
13173  from the currently selected frame. */
13174 
13175  if (has_stack_frames ())
13176  {
13177  prev_len = VEC_length (ada_exc_info, result);
13179  &result);
13180  if (VEC_length (ada_exc_info, result) > prev_len)
13181  sort_remove_dups_ada_exceptions_list (&result, prev_len);
13182  }
13183 
13184  /* Add all exceptions whose scope is global. */
13185 
13186  prev_len = VEC_length (ada_exc_info, result);
13187  ada_add_global_exceptions (preg, &result);
13188  if (VEC_length (ada_exc_info, result) > prev_len)
13189  sort_remove_dups_ada_exceptions_list (&result, prev_len);
13190 
13191  discard_cleanups (old_chain);
13192  return result;
13193 }
13194 
13195 /* Return a vector of ada_exc_info.
13196 
13197  If REGEXP is NULL, all exceptions are included in the result.
13198  Otherwise, it should contain a valid regular expression,
13199  and only the exceptions whose names match that regular expression
13200  are included in the result.
13201 
13202  The exceptions are sorted in the following order:
13203  - Standard exceptions (defined by the Ada language), in
13204  alphabetical order;
13205  - Exceptions only visible from the current frame, in
13206  alphabetical order;
13207  - Exceptions whose scope is global, in alphabetical order. */
13208 
13209 VEC(ada_exc_info) *
13210 ada_exceptions_list (const char *regexp)
13211 {
13212  VEC(ada_exc_info) *result = NULL;
13213  struct cleanup *old_chain = NULL;
13214  regex_t reg;
13215 
13216  if (regexp != NULL)
13217  old_chain = compile_rx_or_error (&reg, regexp,
13218  _("invalid regular expression"));
13219 
13220  result = ada_exceptions_list_1 (regexp != NULL ? &reg : NULL);
13221 
13222  if (old_chain != NULL)
13223  do_cleanups (old_chain);
13224  return result;
13225 }
13226 
13227 /* Implement the "info exceptions" command. */
13228 
13229 static void
13230 info_exceptions_command (char *regexp, int from_tty)
13231 {
13232  VEC(ada_exc_info) *exceptions;
13233  struct cleanup *cleanup;
13234  struct gdbarch *gdbarch = get_current_arch ();
13235  int ix;
13236  struct ada_exc_info *info;
13237 
13238  exceptions = ada_exceptions_list (regexp);
13239  cleanup = make_cleanup (VEC_cleanup (ada_exc_info), &exceptions);
13240 
13241  if (regexp != NULL)
13243  (_("All Ada exceptions matching regular expression \"%s\":\n"), regexp);
13244  else
13245  printf_filtered (_("All defined Ada exceptions:\n"));
13246 
13247  for (ix = 0; VEC_iterate(ada_exc_info, exceptions, ix, info); ix++)
13248  printf_filtered ("%s: %s\n", info->name, paddress (gdbarch, info->addr));
13249 
13250  do_cleanups (cleanup);
13251 }
13252 
13253  /* Operators */
13254 /* Information about operators given special treatment in functions
13255  below. */
13256 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
13257 
13258 #define ADA_OPERATORS \
13259  OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
13260  OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
13261  OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
13262  OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
13263  OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
13264  OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
13265  OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
13266  OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
13267  OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
13268  OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
13269  OP_DEFN (OP_ATR_POS, 1, 2, 0) \
13270  OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
13271  OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
13272  OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
13273  OP_DEFN (UNOP_QUAL, 3, 1, 0) \
13274  OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \
13275  OP_DEFN (OP_OTHERS, 1, 1, 0) \
13276  OP_DEFN (OP_POSITIONAL, 3, 1, 0) \
13277  OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0)
13278 
13279 static void
13280 ada_operator_length (const struct expression *exp, int pc, int *oplenp,
13281  int *argsp)
13282 {
13283  switch (exp->elts[pc - 1].opcode)
13284  {
13285  default:
13286  operator_length_standard (exp, pc, oplenp, argsp);
13287  break;
13288 
13289 #define OP_DEFN(op, len, args, binop) \
13290  case op: *oplenp = len; *argsp = args; break;
13291  ADA_OPERATORS;
13292 #undef OP_DEFN
13293 
13294  case OP_AGGREGATE:
13295  *oplenp = 3;
13296  *argsp = longest_to_int (exp->elts[pc - 2].longconst);
13297  break;
13298 
13299  case OP_CHOICES:
13300  *oplenp = 3;
13301  *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1;
13302  break;
13303  }
13304 }
13305 
13306 /* Implementation of the exp_descriptor method operator_check. */
13307 
13308 static int
13309 ada_operator_check (struct expression *exp, int pos,
13310  int (*objfile_func) (struct objfile *objfile, void *data),
13311  void *data)
13312 {
13313  const union exp_element *const elts = exp->elts;
13314  struct type *type = NULL;
13315 
13316  switch (elts[pos].opcode)
13317  {
13318  case UNOP_IN_RANGE:
13319  case UNOP_QUAL:
13320  type = elts[pos + 1].type;
13321  break;
13322 
13323  default:
13324  return operator_check_standard (exp, pos, objfile_func, data);
13325  }
13326 
13327  /* Invoke callbacks for TYPE and OBJFILE if they were set as non-NULL. */
13328 
13329  if (type && TYPE_OBJFILE (type)
13330  && (*objfile_func) (TYPE_OBJFILE (type), data))
13331  return 1;
13332 
13333  return 0;
13334 }
13335 
13336 static char *
13338 {
13339  switch (opcode)
13340  {
13341  default:
13342  return op_name_standard (opcode);
13343 
13344 #define OP_DEFN(op, len, args, binop) case op: return #op;
13345  ADA_OPERATORS;
13346 #undef OP_DEFN
13347 
13348  case OP_AGGREGATE:
13349  return "OP_AGGREGATE";
13350  case OP_CHOICES:
13351  return "OP_CHOICES";
13352  case OP_NAME:
13353  return "OP_NAME";
13354  }
13355 }
13356 
13357 /* As for operator_length, but assumes PC is pointing at the first
13358  element of the operator, and gives meaningful results only for the
13359  Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */
13360 
13361 static void
13363  int *oplenp, int *argsp)
13364 {
13365  switch (exp->elts[pc].opcode)
13366  {
13367  default:
13368  *oplenp = *argsp = 0;
13369  break;
13370 
13371 #define OP_DEFN(op, len, args, binop) \
13372  case op: *oplenp = len; *argsp = args; break;
13373  ADA_OPERATORS;
13374 #undef OP_DEFN
13375 
13376  case OP_AGGREGATE:
13377  *oplenp = 3;
13378  *argsp = longest_to_int (exp->elts[pc + 1].longconst);
13379  break;
13380 
13381  case OP_CHOICES:
13382  *oplenp = 3;
13383  *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1;
13384  break;
13385 
13386  case OP_STRING:
13387  case OP_NAME:
13388  {
13389  int len = longest_to_int (exp->elts[pc + 1].longconst);
13390 
13391  *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1);
13392  *argsp = 0;
13393  break;
13394  }
13395  }
13396 }
13397 
13398 static int
13399 ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
13400 {
13401  enum exp_opcode op = exp->elts[elt].opcode;
13402  int oplen, nargs;
13403  int pc = elt;
13404  int i;
13405 
13406  ada_forward_operator_length (exp, elt, &oplen, &nargs);
13407 
13408  switch (op)
13409  {
13410  /* Ada attributes ('Foo). */
13411  case OP_ATR_FIRST:
13412  case OP_ATR_LAST:
13413  case OP_ATR_LENGTH:
13414  case OP_ATR_IMAGE:
13415  case OP_ATR_MAX:
13416  case OP_ATR_MIN:
13417  case OP_ATR_MODULUS:
13418  case OP_ATR_POS:
13419  case OP_ATR_SIZE:
13420  case OP_ATR_TAG:
13421  case OP_ATR_VAL:
13422  break;
13423 
13424  case UNOP_IN_RANGE:
13425  case UNOP_QUAL:
13426  /* XXX: gdb_sprint_host_address, type_sprint */
13427  fprintf_filtered (stream, _("Type @"));
13428  gdb_print_host_address (exp->elts[pc + 1].type, stream);
13429  fprintf_filtered (stream, " (");
13430  type_print (exp->elts[pc + 1].type, NULL, stream, 0);
13431  fprintf_filtered (stream, ")");
13432  break;
13433  case BINOP_IN_BOUNDS:
13434  fprintf_filtered (stream, " (%d)",
13435  longest_to_int (exp->elts[pc + 2].longconst));
13436  break;
13437  case TERNOP_IN_RANGE:
13438  break;
13439 
13440  case OP_AGGREGATE:
13441  case OP_OTHERS:
13442  case OP_DISCRETE_RANGE:
13443  case OP_POSITIONAL:
13444  case OP_CHOICES:
13445  break;
13446 
13447  case OP_NAME:
13448  case OP_STRING:
13449  {
13450  char *name = &exp->elts[elt + 2].string;
13451  int len = longest_to_int (exp->elts[elt + 1].longconst);
13452 
13453  fprintf_filtered (stream, "Text: `%.*s'", len, name);
13454  break;
13455  }
13456 
13457  default:
13458  return dump_subexp_body_standard (exp, stream, elt);
13459  }
13460 
13461  elt += oplen;
13462  for (i = 0; i < nargs; i += 1)
13463  elt = dump_subexp (exp, stream, elt);
13464 
13465  return elt;
13466 }
13467 
13468 /* The Ada extension of print_subexp (q.v.). */
13469 
13470 static void
13471 ada_print_subexp (struct expression *exp, int *pos,
13472  struct ui_file *stream, enum precedence prec)
13473 {
13474  int oplen, nargs, i;
13475  int pc = *pos;
13476  enum exp_opcode op = exp->elts[pc].opcode;
13477 
13478  ada_forward_operator_length (exp, pc, &oplen, &nargs);
13479 
13480  *pos += oplen;
13481  switch (op)
13482  {
13483  default:
13484  *pos -= oplen;
13485  print_subexp_standard (exp, pos, stream, prec);
13486  return;
13487 
13488  case OP_VAR_VALUE:
13489  fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
13490  return;
13491 
13492  case BINOP_IN_BOUNDS:
13493  /* XXX: sprint_subexp */
13494  print_subexp (exp, pos, stream, PREC_SUFFIX);
13495  fputs_filtered (" in ", stream);
13496  print_subexp (exp, pos, stream, PREC_SUFFIX);
13497  fputs_filtered ("'range", stream);
13498  if (exp->elts[pc + 1].longconst > 1)
13499  fprintf_filtered (stream, "(%ld)",
13500  (long) exp->elts[pc + 1].longconst);
13501  return;
13502 
13503  case TERNOP_IN_RANGE:
13504  if (prec >= PREC_EQUAL)
13505  fputs_filtered ("(", stream);
13506  /* XXX: sprint_subexp */
13507  print_subexp (exp, pos, stream, PREC_SUFFIX);
13508  fputs_filtered (" in ", stream);
13509  print_subexp (exp, pos, stream, PREC_EQUAL);
13510  fputs_filtered (" .. ", stream);
13511  print_subexp (exp, pos, stream, PREC_EQUAL);
13512  if (prec >= PREC_EQUAL)
13513  fputs_filtered (")", stream);
13514  return;
13515 
13516  case OP_ATR_FIRST:
13517  case OP_ATR_LAST:
13518  case OP_ATR_LENGTH:
13519  case OP_ATR_IMAGE:
13520  case OP_ATR_MAX:
13521  case OP_ATR_MIN:
13522  case OP_ATR_MODULUS:
13523  case OP_ATR_POS:
13524  case OP_ATR_SIZE:
13525  case OP_ATR_TAG:
13526  case OP_ATR_VAL:
13527  if (exp->elts[*pos].opcode == OP_TYPE)
13528  {
13529  if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
13530  LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0,
13532  *pos += 3;
13533  }
13534  else
13535  print_subexp (exp, pos, stream, PREC_SUFFIX);
13536  fprintf_filtered (stream, "'%s", ada_attribute_name (op));
13537  if (nargs > 1)
13538  {
13539  int tem;
13540 
13541  for (tem = 1; tem < nargs; tem += 1)
13542  {
13543  fputs_filtered ((tem == 1) ? " (" : ", ", stream);
13544  print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
13545  }
13546  fputs_filtered (")", stream);
13547  }
13548  return;
13549 
13550  case UNOP_QUAL:
13551  type_print (exp->elts[pc + 1].type, "", stream, 0);
13552  fputs_filtered ("'(", stream);
13553  print_subexp (exp, pos, stream, PREC_PREFIX);
13554  fputs_filtered (")", stream);
13555  return;
13556 
13557  case UNOP_IN_RANGE:
13558  /* XXX: sprint_subexp */
13559  print_subexp (exp, pos, stream, PREC_SUFFIX);
13560  fputs_filtered (" in ", stream);
13561  LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0,
13563  return;
13564 
13565  case OP_DISCRETE_RANGE:
13566  print_subexp (exp, pos, stream, PREC_SUFFIX);
13567  fputs_filtered ("..", stream);
13568  print_subexp (exp, pos, stream, PREC_SUFFIX);
13569  return;
13570 
13571  case OP_OTHERS:
13572  fputs_filtered ("others => ", stream);
13573  print_subexp (exp, pos, stream, PREC_SUFFIX);
13574  return;
13575 
13576  case OP_CHOICES:
13577  for (i = 0; i < nargs-1; i += 1)
13578  {
13579  if (i > 0)
13580  fputs_filtered ("|", stream);
13581  print_subexp (exp, pos, stream, PREC_SUFFIX);
13582  }
13583  fputs_filtered (" => ", stream);
13584  print_subexp (exp, pos, stream, PREC_SUFFIX);
13585  return;
13586 
13587  case OP_POSITIONAL:
13588  print_subexp (exp, pos, stream, PREC_SUFFIX);
13589  return;
13590 
13591  case OP_AGGREGATE:
13592  fputs_filtered ("(", stream);
13593  for (i = 0; i < nargs; i += 1)
13594  {
13595  if (i > 0)
13596  fputs_filtered (", ", stream);
13597  print_subexp (exp, pos, stream, PREC_SUFFIX);
13598  }
13599  fputs_filtered (")", stream);
13600  return;
13601  }
13602 }
13603 
13604 /* Table mapping opcodes into strings for printing operators
13605  and precedences of the operators. */
13606 
13607 static const struct op_print ada_op_print_tab[] = {
13608  {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
13609  {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
13610  {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
13611  {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
13612  {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
13613  {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
13614  {"=", BINOP_EQUAL, PREC_EQUAL, 0},
13615  {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
13616  {"<=", BINOP_LEQ, PREC_ORDER, 0},
13617  {">=", BINOP_GEQ, PREC_ORDER, 0},
13618  {">", BINOP_GTR, PREC_ORDER, 0},
13619  {"<", BINOP_LESS, PREC_ORDER, 0},
13620  {">>", BINOP_RSH, PREC_SHIFT, 0},
13621  {"<<", BINOP_LSH, PREC_SHIFT, 0},
13622  {"+", BINOP_ADD, PREC_ADD, 0},
13623  {"-", BINOP_SUB, PREC_ADD, 0},
13624  {"&", BINOP_CONCAT, PREC_ADD, 0},
13625  {"*", BINOP_MUL, PREC_MUL, 0},
13626  {"/", BINOP_DIV, PREC_MUL, 0},
13627  {"rem", BINOP_REM, PREC_MUL, 0},
13628  {"mod", BINOP_MOD, PREC_MUL, 0},
13629  {"**", BINOP_EXP, PREC_REPEAT, 0},
13630  {"@", BINOP_REPEAT, PREC_REPEAT, 0},
13631  {"-", UNOP_NEG, PREC_PREFIX, 0},
13632  {"+", UNOP_PLUS, PREC_PREFIX, 0},
13633  {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
13634  {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
13635  {"abs ", UNOP_ABS, PREC_PREFIX, 0},
13636  {".all", UNOP_IND, PREC_SUFFIX, 1},
13637  {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
13638  {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
13639  {NULL, 0, 0, 0}
13640 };
13641 
13656 };
13657 
13658 static void
13660  struct language_arch_info *lai)
13661 {
13662  const struct builtin_type *builtin = builtin_type (gdbarch);
13663 
13666  struct type *);
13667 
13669  = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13670  0, "integer");
13672  = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch),
13673  0, "long_integer");
13675  = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch),
13676  0, "short_integer");
13677  lai->string_char_type
13679  = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
13681  = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
13682  "float", NULL);
13684  = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13685  "long_float", NULL);
13687  = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch),
13688  0, "long_long_integer");
13690  = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
13691  "long_long_float", NULL);
13693  = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13694  0, "natural");
13696  = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch),
13697  0, "positive");
13699  = builtin->builtin_void;
13700 
13702  = lookup_pointer_type (arch_type (gdbarch, TYPE_CODE_VOID, 1, "void"));
13704  = "system__address";
13705 
13706  lai->bool_type_symbol = NULL;
13707  lai->bool_type_default = builtin->builtin_bool;
13708 }
13709 
13710  /* Language vector */
13711 
13712 /* Not really used, but needed in the ada_language_defn. */
13713 
13714 static void
13715 emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
13716 {
13717  ada_emit_char (c, type, stream, quoter, 1);
13718 }
13719 
13720 static int
13722 {
13723  warnings_issued = 0;
13724  return ada_parse (ps);
13725 }
13726 
13727 static const struct exp_descriptor ada_exp_descriptor = {
13731  ada_op_name,
13734 };
13735 
13736 /* Implement the "la_get_symbol_name_cmp" language_defn method
13737  for Ada. */
13738 
13739 static symbol_name_cmp_ftype
13740 ada_get_symbol_name_cmp (const char *lookup_name)
13741 {
13742  if (should_use_wild_match (lookup_name))
13743  return wild_match;
13744  else
13745  return compare_names;
13746 }
13747 
13748 /* Implement the "la_read_var_value" language_defn method for Ada. */
13749 
13750 static struct value *
13751 ada_read_var_value (struct symbol *var, struct frame_info *frame)
13752 {
13753  const struct block *frame_block = NULL;
13754  struct symbol *renaming_sym = NULL;
13755 
13756  /* The only case where default_read_var_value is not sufficient
13757  is when VAR is a renaming... */
13758  if (frame)
13759  frame_block = get_frame_block (frame, NULL);
13760  if (frame_block)
13761  renaming_sym = ada_find_renaming_symbol (var, frame_block);
13762  if (renaming_sym != NULL)
13763  return ada_read_renaming_var_value (renaming_sym, frame_block);
13764 
13765  /* This is a typical case where we expect the default_read_var_value
13766  function to work. */
13767  return default_read_var_value (var, frame);
13768 }
13769 
13770 const struct language_defn ada_language_defn = {
13771  "ada", /* Language name */
13772  "Ada",
13773  language_ada,
13775  case_sensitive_on, /* Yes, Ada is case-insensitive, but
13776  that's not quite what this means. */
13780  parse,
13781  ada_error,
13782  resolve,
13783  ada_printchar, /* Print a character constant */
13784  ada_printstr, /* Function to print string constant */
13785  emit_char, /* Function to print single char (not used) */
13786  ada_print_type, /* Print a type using appropriate syntax */
13787  ada_print_typedef, /* Print a typedef using appropriate syntax */
13788  ada_val_print, /* Print a value using appropriate syntax */
13789  ada_value_print, /* Print a top-level value */
13790  ada_read_var_value, /* la_read_var_value */
13791  NULL, /* Language specific skip_trampoline */
13792  NULL, /* name_of_this */
13793  ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
13794  basic_lookup_transparent_type, /* lookup_transparent_type */
13795  ada_la_decode, /* Language specific symbol demangler */
13796  NULL, /* Language specific
13797  class_name_from_physname */
13798  ada_op_print_tab, /* expression operators for printing */
13799  0, /* c-style arrays */
13800  1, /* String lower bound */
13802  ada_make_symbol_completion_list,
13806  c_get_string,
13807  ada_get_symbol_name_cmp, /* la_get_symbol_name_cmp */
13809  &ada_varobj_ops,
13810  NULL,
13811  NULL,
13812  LANG_MAGIC
13813 };
13814 
13815 /* Provide a prototype to silence -Wmissing-prototypes. */
13817 
13818 /* Command-list for the "set/show ada" prefix command. */
13821 
13822 /* Implement the "set ada" prefix command. */
13823 
13824 static void
13825 set_ada_command (char *arg, int from_tty)
13826 {
13827  printf_unfiltered (_(\
13828 "\"set ada\" must be followed by the name of a setting.\n"));
13829  help_list (set_ada_list, "set ada ", all_commands, gdb_stdout);
13830 }
13831 
13832 /* Implement the "show ada" prefix command. */
13833 
13834 static void
13835 show_ada_command (char *args, int from_tty)
13836 {
13837  cmd_show_list (show_ada_list, from_tty, "");
13838 }
13839 
13840 static void
13842 {
13843  struct breakpoint_ops *ops;
13844 
13846 
13848  *ops = bkpt_breakpoint_ops;
13849  ops->dtor = dtor_catch_exception;
13857 
13859  *ops = bkpt_breakpoint_ops;
13868 
13870  *ops = bkpt_breakpoint_ops;
13871  ops->dtor = dtor_catch_assert;
13873  ops->re_set = re_set_catch_assert;
13879 }
13880 
13881 /* This module's 'new_objfile' observer. */
13882 
13883 static void
13885 {
13887 }
13888 
13889 /* This module's 'free_objfile' observer. */
13890 
13891 static void
13893 {
13895 }
13896 
13897 void
13899 {
13900  add_language (&ada_language_defn);
13901 
13903 
13905  _("Prefix command for changing Ada-specfic settings"),
13906  &set_ada_list, "set ada ", 0, &setlist);
13907 
13909  _("Generic command for showing Ada-specific settings."),
13910  &show_ada_list, "show ada ", 0, &showlist);
13911 
13912  add_setshow_boolean_cmd ("trust-PAD-over-XVS", class_obscure,
13913  &trust_pad_over_xvs, _("\
13914 Enable or disable an optimization trusting PAD types over XVS types"), _("\
13915 Show whether an optimization trusting PAD types over XVS types is activated"),
13916  _("\
13917 This is related to the encoding used by the GNAT compiler. The debugger\n\
13918 should normally trust the contents of PAD types, but certain older versions\n\
13919 of GNAT have a bug that sometimes causes the information in the PAD type\n\
13920 to be incorrect. Turning this setting \"off\" allows the debugger to\n\
13921 work around this bug. It is always safe to turn this option \"off\", but\n\
13922 this incurs a slight performance penalty, so it is recommended to NOT change\n\
13923 this option to \"off\" unless necessary."),
13924  NULL, NULL, &set_ada_list, &show_ada_list);
13925 
13926  add_catch_command ("exception", _("\
13927 Catch Ada exceptions, when raised.\n\
13928 With an argument, catch only exceptions with the given name."),
13930  NULL,
13932  CATCH_TEMPORARY);
13933  add_catch_command ("assert", _("\
13934 Catch failed Ada assertions, when raised.\n\
13935 With an argument, catch only exceptions with the given name."),
13937  NULL,
13939  CATCH_TEMPORARY);
13940 
13941  varsize_limit = 65536;
13942 
13943  add_info ("exceptions", info_exceptions_command,
13944  _("\
13945 List all Ada exception names.\n\
13946 If a regular expression is passed as an argument, only those matching\n\
13947 the regular expression are listed."));
13948 
13950  _("Set Ada maintenance-related variables."),
13951  &maint_set_ada_cmdlist, "maintenance set ada ",
13952  0/*allow-unknown*/, &maintenance_set_cmdlist);
13953 
13955  _("Show Ada maintenance-related variables"),
13956  &maint_show_ada_cmdlist, "maintenance show ada ",
13957  0/*allow-unknown*/, &maintenance_show_cmdlist);
13958 
13960  ("ignore-descriptive-types", class_maintenance,
13961  &ada_ignore_descriptive_types_p,
13962  _("Set whether descriptive types generated by GNAT should be ignored."),
13963  _("Show whether descriptive types generated by GNAT should be ignored."),
13964  _("\
13965 When enabled, the debugger will stop using the DW_AT_GNAT_descriptive_type\n\
13966 DWARF attribute."),
13967  NULL, NULL, &maint_set_ada_cmdlist, &maint_show_ada_cmdlist);
13968 
13969  obstack_init (&symbol_list_obstack);
13970 
13971  decoded_names_store = htab_create_alloc
13972  (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
13973  NULL, xcalloc, xfree);
13974 
13975  /* The ada-lang observers. */
13979 
13980  /* Setup various context-specific data. */
13981  ada_inferior_data
13982  = register_inferior_data_with_cleanup (NULL, ada_inferior_data_cleanup);
13983  ada_pspace_data_handle
13984  = register_program_space_data_with_cleanup (NULL, ada_pspace_data_cleanup);
13985 }
void ada_emit_char(int, struct type *, struct ui_file *, int, int)
Definition: ada-valprint.c:258
static int ada_is_redundant_range_encoding(struct type *range_type, struct type *encoding_type)
Definition: ada-lang.c:8484
void error_no_arg(const char *why)
Definition: cli-cmds.c:205
struct gdbarch * target_gdbarch(void)
Definition: gdbarch.c:5143
void set_value_bitpos(struct value *value, int bit)
Definition: value.c:1048
static int is_valid_name_for_wild_match(const char *name0)
Definition: ada-lang.c:5869
static struct 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:5679
struct value * value_zero(struct type *type, enum lval_type lv)
Definition: valops.c:842
static void replace_operator_with_call(struct expression **, int, int, int, struct symbol *, const struct block *)
Definition: ada-lang.c:3932
void target_terminal_ours(void)
Definition: target.c:491
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:8238
static void ada_remove_trailing_digits(const char *encoded, int *len)
Definition: ada-lang.c:1075
CORE_ADDR( ada_unhandled_exception_name_addr_ftype)(void)
Definition: ada-lang.c:11600
union exp_element elts[1]
Definition: expression.h:85
ULONGEST extract_unsigned_integer(const gdb_byte *, int, enum bfd_endian)
Definition: findvar.c:84
int ada_is_character_type(struct type *type)
Definition: ada-lang.c:9088
struct value * value_mark(void)
Definition: value.c:1499
static int desc_bound_bitpos(struct type *, int, int)
Definition: ada-lang.c:1816
static int should_stop_exception(const struct bp_location *bl)
Definition: ada-lang.c:12140
struct cmd_list_element * add_prefix_cmd(const char *name, enum command_class theclass, cmd_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:338
static int ada_lookup_symbol_list_worker(const char *name0, const struct block *block0, domain_enum domain, struct ada_symbol_info **results, int full_search)
Definition: ada-lang.c:5480
const char * symtab_to_filename_for_display(struct symtab *symtab)
Definition: source.c:1171
type_code
Definition: gdbtypes.h:85
struct value * ada_get_decoded_value(struct value *value)
Definition: ada-lang.c:856
void(* print_recreate)(struct breakpoint *, struct ui_file *fp)
Definition: breakpoint.h:575
static void ada_add_exceptions_from_frame(regex_t *preg, struct frame_info *frame, VEC(ada_exc_info)**exceptions)
Definition: ada-lang.c:13064
static void print_mention_catch_exception_unhandled(struct breakpoint *b)
Definition: ada-lang.c:12475
static void create_excep_cond_exprs(struct ada_catchpoint *c)
Definition: ada-lang.c:12031
static void ada_operator_length(const struct expression *exp, int pc, int *oplenp, int *argsp)
Definition: ada-lang.c:13280
LONGEST get_int_var_value(char *name, int *flag)
Definition: ada-lang.c:11397
struct value * call_function_by_hand(struct value *function, int nargs, struct value **args)
Definition: infcall.c:488
void value_contents_copy_raw(struct value *dst, int dst_offset, struct value *src, int src_offset, int length)
Definition: value.c:1248
struct symbol * language_lookup_primitive_type_as_symbol(const struct language_defn *la, struct gdbarch *gdbarch, const char *name)
Definition: language.c:1087
static int ada_args_match(struct symbol *, struct value **, int)
Definition: ada-lang.c:3551
struct 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:1949
static struct value * ada_value_slice(struct value *array, int low, int high)
Definition: ada-lang.c:2817
struct value * value_addr(struct value *arg1)
Definition: valops.c:1472
struct value * ada_value_struct_elt(struct value *arg, char *name, int no_err)
Definition: ada-lang.c:7245
int ada_get_field_index(const struct type *type, const char *field_name, int maybe_missing)
Definition: ada-lang.c:614
struct value * value_primitive_field(struct value *arg1, int offset, int fieldno, struct type *arg_type)
Definition: value.c:2990
static void sort_choices(struct ada_symbol_info syms[], int nsyms)
Definition: ada-lang.c:3707
struct type * copy_type(const struct type *type)
Definition: gdbtypes.c:4507
struct frame_info * get_selected_frame(const char *message)
Definition: frame.c:1535
int ada_is_bogus_array_descriptor(struct type *type)
Definition: ada-lang.c:1925
static int ada_has_this_exception_support(const struct exception_support_info *einfo)
Definition: ada-lang.c:11661
void init_bp_location(struct bp_location *loc, const struct bp_location_ops *ops, struct breakpoint *owner)
Definition: breakpoint.c:7152
void * get_cmd_context(struct cmd_list_element *cmd)
Definition: cli-decode.c:147
static int old_renaming_is_invisible(const struct symbol *sym, const char *function_name)
Definition: ada-lang.c:5080
static char * ada_get_next_arg(char **argsp)
Definition: ada-lang.c:12548
struct type * create_static_range_type(struct type *result_type, struct type *index_type, LONGEST low_bound, LONGEST high_bound)
Definition: gdbtypes.c:867
static void resolve(struct expression **expp, int void_context_p)
Definition: ada-lang.c:3120
struct observer * observer_attach_free_objfile(observer_free_objfile_ftype *f)
#define SYMBOL_PRINT_NAME(symbol)
Definition: symtab.h:260
static void print_one_catch_exception_unhandled(struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:12468
void value_free_to_mark(struct value *mark)
Definition: value.c:1551
static int advance_wild_match(const char **, const char *, int)
Definition: ada-lang.c:5892
static int wild_match(const char *, const char *)
Definition: ada-lang.c:5936
struct type * ada_parent_type(struct type *type)
Definition: ada-lang.c:6746
enum exp_opcode opcode
Definition: expression.h:65
struct value * value_subscript(struct value *array, LONGEST index)
Definition: valarith.c:146
union general_symbol_info::@159 language_specific
const char * ada_tag_name(struct value *tag)
Definition: ada-lang.c:6712
#define MSYMBOL_LINKAGE_NAME(symbol)
Definition: symtab.h:409
void ui_out_field_int(struct ui_out *uiout, const char *fldname, int value)
Definition: ui-out.c:467
struct frame_info * get_current_frame(void)
Definition: frame.c:1461
struct value * value_from_contents_and_address(struct type *type, const gdb_byte *valaddr, CORE_ADDR address)
Definition: value.c:3529
static int field_name_match(const char *field_name, const char *target)
Definition: ada-lang.c:592
bfd_vma CORE_ADDR
Definition: common-types.h:41
noside
Definition: expression.h:122
static void ada_add_local_symbols(struct obstack *obstackp, const char *name, const struct block *block, domain_enum domain, int wild_match_p)
Definition: ada-lang.c:5254
void read_memory_string(CORE_ADDR memaddr, char *buffer, int max_len)
Definition: corefile.c:351
static const struct exp_descriptor ada_exp_descriptor
Definition: ada-lang.c:13727
#define TYPE_FIELD_NAME(thistype, n)
Definition: gdbtypes.h:1369
int( symbol_found_callback_ftype)(struct symbol *sym, void *data)
Definition: symtab.h:1580
static struct value * value_val_atr(struct type *, struct value *)
Definition: ada-lang.c:9061
static const gdb_byte * cond_offset_host(const gdb_byte *valaddr, long offset)
Definition: ada-lang.c:698
static void ada_print_array_index(struct value *index_value, struct ui_file *stream, const struct value_print_options *options)
Definition: ada-lang.c:564
static struct type * thin_descriptor_type(struct type *type)
Definition: ada-lang.c:1581
const struct lang_varobj_ops ada_varobj_ops
Definition: ada-varobj.c:1032
const char multiple_symbols_cancel[]
Definition: symtab.c:228
char * ada_encode(const char *decoded)
Definition: ada-lang.c:979
void xfree(void *)
Definition: common-utils.c:97
int ada_is_others_clause(struct type *type, int field_num)
Definition: ada-lang.c:6837
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:2390
#define HAVE_GNAT_AUX_INFO(type)
Definition: gdbtypes.h:1216
#define TYPE_LOW_BOUND(range_type)
Definition: gdbtypes.h:1246
struct value * value_ref(struct value *arg1)
Definition: valops.c:1516
struct obstack * obstackp
Definition: ada-lang.c:5286
#define GDBARCH_OBSTACK_CALLOC(GDBARCH, NR, TYPE)
Definition: gdbarch.h:1614
struct frame_info * get_prev_frame(struct frame_info *this_frame)
Definition: frame.c:2122
static int parse(struct parser_state *ps)
Definition: ada-lang.c:13721
#define TYPE_OBJFILE(t)
Definition: gdbtypes.h:326
LONGEST value_as_long(struct value *val)
Definition: value.c:2654
void ada_lookup_encoded_symbol(const char *name, const struct block *block, domain_enum domain, struct ada_symbol_info *info)
Definition: ada-lang.c:5640
int gdbarch_int_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1490
void(* func)(char *)
#define INT_MAX
Definition: defs.h:509
#define BMSYMBOL_VALUE_ADDRESS(symbol)
Definition: symtab.h:393
void warning(const char *fmt,...)
Definition: errors.c:26
#define CATCH_TEMPORARY
Definition: breakpoint.h:1247
struct breakpoint base
Definition: ada-lang.c:12021
static void ada_iterate_over_symbols(const struct block *block, const char *name, domain_enum domain, symbol_found_callback_ftype *callback, void *data)
Definition: ada-lang.c:5591
static struct breakpoint_ops catch_exception_unhandled_breakpoint_ops
Definition: ada-lang.c:12487
struct type ** const(pascal_builtin_types[])
struct value * evaluate_subexp_with_coercion(struct expression *exp, int *pos, enum noside noside)
Definition: eval.c:2958
struct type * create_array_type(struct type *result_type, struct type *element_type, struct type *range_type)
Definition: gdbtypes.c:1119
const char * name
Definition: ada-lang.h:395
#define TYPE_NAME(thistype)
Definition: gdbtypes.h:1227
static struct value * ada_value_cast(struct type *type, struct value *arg2, enum noside noside)
Definition: ada-lang.c:9911
char * ada_fold_name(const char *name)
Definition: ada-lang.c:1030
enum print_stop_action(* print_it)(struct bpstats *bs)
Definition: breakpoint.h:550
struct objfile * objfile
Definition: ada-lang.c:5285
#define INIT_CPLUS_SPECIFIC(type)
Definition: gdbtypes.h:1195
initialize_file_ftype _initialize_ada_language
int value_bitpos(const struct value *value)
Definition: value.c:1043
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:8826
struct value * value_at(struct type *type, CORE_ADDR addr)
Definition: valops.c:940
int ada_in_variant(LONGEST val, struct type *type, int field_num)
Definition: ada-lang.c:6945
#define TYPE_HIGH_BOUND(range_type)
Definition: gdbtypes.h:1248
struct type * arch_float_type(struct gdbarch *gdbarch, int bit, char *name, const struct floatformat **floatformats)
Definition: gdbtypes.c:4606
void annotate_field(int num)
Definition: annotate.c:188
enum domain_enum_tag domain_enum
static int num_visible_fields(struct type *type)
Definition: ada-lang.c:7108
struct ui_file * gdb_stdout
Definition: main.c:71
const struct type_print_options type_print_raw_options
Definition: typeprint.c:48
const struct builtin_type * builtin_type(struct gdbarch *gdbarch)
Definition: gdbtypes.c:4766
static struct type * empty_record(struct type *templ)
Definition: ada-lang.c:7959
static int warnings_issued
Definition: ada-lang.c:331
ada_primitive_types
Definition: ada-lang.c:13642
struct value * allocate_value_lazy(struct type *type)
Definition: value.c:913
void select_frame(struct frame_info *fi)
Definition: frame.c:1574
struct type * ada_variant_discrim_type(struct type *var_type, struct type *outer_type)
Definition: ada-lang.c:6825
static struct value * value_pos_atr(struct type *, struct value *)
Definition: ada-lang.c:9053
#define SYMBOL_CLASS(symbol)
Definition: symtab.h:793
static void check_status_catch_exception_unhandled(bpstat bs)
Definition: ada-lang.c:12456
void internal_error(const char *file, int line, const char *fmt,...)
Definition: errors.c:50
void binop_promote(const struct language_defn *language, struct gdbarch *gdbarch, struct value **arg1, struct value **arg2)
Definition: eval.c:466
#define HASH_SIZE
Definition: ada-lang.c:297
static struct value * desc_one_bound(struct value *, int, int)
Definition: ada-lang.c:1805
static struct type * constrained_packed_array_type(struct type *, long *)
Definition: ada-lang.c:2165
static LONGEST min_of_size(int size)
Definition: ada-lang.c:759
const struct language_defn * language_defn
Definition: expression.h:81
static char * standard_exc[]
Definition: ada-lang.c:11593
int ui_out_is_mi_like_p(struct ui_out *uiout)
Definition: ui-out.c:655
static struct breakpoint_ops catch_assert_breakpoint_ops
Definition: ada-lang.c:12539
const char * ada_decode(const char *encoded)
Definition: ada-lang.c:1145
static CORE_ADDR ada_exception_name_addr(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:11945
struct obstack cache_space
Definition: ada-lang.c:302
void ada_print_typedef(struct type *type, struct symbol *new_symbol, struct ui_file *stream)
void(* print_mention)(struct breakpoint *)
Definition: breakpoint.h:572
void find_frame_funname(struct frame_info *frame, char **funname, enum language *funlang, struct symbol **funcp)
Definition: stack.c:1053
static int ada_type_match(struct type *, struct type *, int)
Definition: ada-lang.c:3493
void ada_print_type(struct type *, const char *, struct ui_file *, int, int, const struct type_print_options *)
static int ada_complete_symbol_matcher(const char *name, void *user_data)
Definition: ada-lang.c:6256
struct value * default_read_var_value(struct symbol *var, struct frame_info *frame)
Definition: findvar.c:416
static void value_assign_to_component(struct value *container, struct value *component, struct value *val)
Definition: ada-lang.c:2699
struct value * coerce_ref(struct value *arg)
Definition: value.c:3688
static struct value * ensure_lval(struct value *val)
Definition: ada-lang.c:4292
struct symbol * block_linkage_function(const struct block *bl)
Definition: block.c:100
void type_print(struct type *type, const char *varstring, struct ui_file *stream, int show)
Definition: typeprint.c:360
struct value * value_ind(struct value *arg1)
Definition: valops.c:1533
int gdbarch_long_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1507
struct value * value_copy(struct value *arg)
Definition: value.c:1667
CORE_ADDR addr
Definition: ada-lang.h:398
const struct block * innermost_block
Definition: parse.c:69
static const struct exception_support_info exception_support_info_fallback
Definition: ada-lang.c:11645
struct type * ada_get_base_type(struct type *raw_type)
Definition: ada-lang.c:9161
static struct type * to_fixed_variant_branch_type(struct type *, const gdb_byte *, CORE_ADDR, struct value *)
Definition: ada-lang.c:8442
struct type * ada_coerce_to_simple_array_type(struct type *type)
Definition: ada-lang.c:2066
struct value * value_from_contents_and_address_unresolved(struct type *type, const gdb_byte *valaddr, CORE_ADDR address)
Definition: value.c:3508
struct bp_location *(* allocate_location)(struct breakpoint *)
Definition: breakpoint.h:505
static void ada_print_subexp(struct expression *exp, int *pos, struct ui_file *stream, enum precedence prec)
Definition: ada-lang.c:13471
static struct type * to_fixed_range_type(struct type *, struct value *)
Definition: ada-lang.c:11426
struct observer * observer_attach_inferior_exit(observer_inferior_exit_ftype *f)
#define VEC_safe_push(T, V, O)
Definition: vec.h:260
#define BLOCKVECTOR_BLOCK(blocklist, n)
Definition: block.h:136
static void maint_set_ada_cmd(char *args, int from_tty)
Definition: ada-lang.c:352
static LONGEST ada_array_length(struct value *arr, int n)
Definition: ada-lang.c:3036
static int ada_ignore_descriptive_types_p
Definition: ada-lang.c:368
const char * decoded
Definition: ada-lang.h:74
const char * filename
Definition: symtab.h:943
const char * catch_assert_sym
Definition: ada-lang.c:11617
domain_enum domain
Definition: ada-lang.c:277
static void print_recreate_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:12356
static int integer_type_p(struct type *)
Definition: ada-lang.c:3990
static struct type * static_unwrap_type(struct type *type)
Definition: ada-lang.c:8896
static struct value * ada_value_primitive_field(struct value *, int, int, struct type *)
Definition: ada-lang.c:6994
const char * catch_exception_unhandled_sym
Definition: ada-lang.c:11613
Definition: ada-lang.c:272
static struct value * ada_search_struct_field(char *, struct value *, int, struct type *)
Definition: ada-lang.c:7124
char * skip_spaces(char *chp)
Definition: common-utils.c:259
static void check_status_catch_exception(bpstat bs)
Definition: ada-lang.c:12404
static int remove_extra_symbols(struct ada_symbol_info *syms, int nsyms)
Definition: ada-lang.c:4928
static const char * known_runtime_file_name_patterns[]
Definition: ada-lang.c:333
#define _(String)
Definition: gdb_locale.h:40
static void print_recreate_catch_exception_unhandled(struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:12481
static int aux_add_nonlocal_symbols(struct block *block, struct symbol *sym, void *data0)
Definition: ada-lang.c:5301
static struct value * evaluate_subexp_type(struct expression *, int *)
Definition: ada-lang.c:9311
static struct bp_location * allocate_location_catch_assert(struct breakpoint *self)
Definition: ada-lang.c:12498
struct symtab_and_line find_function_start_sal(struct symbol *sym, int funfirstline)
Definition: symtab.c:3613
static char * add_angle_brackets(const char *str)
Definition: ada-lang.c:546
struct type * string_char_type
Definition: language.h:120
static struct value * get_var_value(char *, char *)
Definition: ada-lang.c:11373
#define SET_FIELD_BITPOS(thisfld, bitpos)
Definition: gdbtypes.h:1349
int ada_is_range_type_name(const char *name)
Definition: ada-lang.c:11524
#define TYPE_FIELD(thistype, n)
Definition: gdbtypes.h:1367
struct obstack * obstack
Definition: gdbarch.c:124
static int is_nonfunction(struct ada_symbol_info *, int)
struct obstack * obstack
Definition: symtab.h:134
char * char_ptr
Definition: gdb_vecs.h:25
void add_catch_command(char *name, char *docstring, cmd_sfunc_ftype *sfunc, completer_ftype *completer, void *user_data_catch, void *user_data_tcatch)
Definition: breakpoint.c:15474
void init_ada_exception_breakpoint(struct breakpoint *b, struct gdbarch *gdbarch, struct symtab_and_line sal, char *addr_string, const struct breakpoint_ops *ops, int tempflag, int enabled, int from_tty)
Definition: breakpoint.c:11665
#define bits(obj, st, fn)
static const char * known_auxiliary_function_name_patterns[]
Definition: ada-lang.c:337
struct type * ada_check_typedef(struct type *type)
Definition: ada-lang.c:8932
static struct type * to_fixed_array_type(struct type *, struct value *, int)
Definition: ada-lang.c:8561
static int is_known_support_routine(struct frame_info *frame)
Definition: ada-lang.c:11768
#define BYTES_TO_EXP_ELEM(bytes)
Definition: expression.h:93
struct value * call_internal_function(struct gdbarch *gdbarch, const struct language_defn *language, struct value *func, int argc, struct value **argv)
Definition: value.c:2438
#define TYPE_FIELD_ENUMVAL(thistype, n)
Definition: gdbtypes.h:1372
#define END_CATCH
#define TYPE_FIELD_TYPE(thistype, n)
Definition: gdbtypes.h:1368
struct cache_entry * next
Definition: ada-lang.c:285
const gdb_byte * ada_aligned_value_addr(struct type *type, const gdb_byte *valaddr)
Definition: ada-lang.c:9222
#define VALUE_LVAL(val)
Definition: value.h:411
int ada_is_string_type(struct type *type)
Definition: ada-lang.c:9112
struct value * allocate_value(struct type *type)
Definition: value.c:962
static struct cmd_list_element * show_ada_list
Definition: ada-lang.c:13820
static struct type * desc_base_type(struct type *)
Definition: ada-lang.c:1552
Definition: ui-out.c:99
static enum print_stop_action print_it_catch_assert(bpstat bs)
Definition: ada-lang.c:12516
static void print_recreate_catch_exception(struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:12428
struct cmd_list_element * maintenance_set_cmdlist
Definition: maint.c:646
tuple m
Definition: arm-linux.py:44
static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
Definition: ada-lang.c:324
void add_language(const struct language_defn *lang)
Definition: language.c:518
void c_get_string(struct value *value, gdb_byte **buffer, int *length, struct type **char_type, const char **charset)
Definition: c-lang.c:239
void ui_out_text(struct ui_out *uiout, const char *string)
Definition: ui-out.c:582
static int equiv_types(struct type *, struct type *)
Definition: ada-lang.c:4637
const struct block * block_for_pc(CORE_ADDR pc)
Definition: block.c:282
static struct type * ada_lookup_struct_elt_type(struct type *, char *, int, int, int *)
Definition: ada-lang.c:7347
const char * ada_attribute_name(enum exp_opcode n)
Definition: ada-lang.c:9026
static CORE_ADDR ada_unhandled_exception_name_addr(void)
Definition: ada-lang.c:11852
void store_unsigned_integer(gdb_byte *, int, enum bfd_endian, ULONGEST)
Definition: findvar.c:212
void printf_filtered(const char *format,...)
Definition: utils.c:2388
static int ada_is_exception_sym(struct symbol *sym)
Definition: ada-lang.c:12909
int longest_to_int(LONGEST)
Definition: valprint.c:1054
static void ada_remove_Xbn_suffix(const char *encoded, int *len)
Definition: ada-lang.c:1119
const struct block * block
Definition: ada-lang.h:90
const char * paddress(struct gdbarch *gdbarch, CORE_ADDR addr)
Definition: utils.c:2743
static const char * ada_exception_sym_name(enum ada_exception_catchpoint_kind ex)
Definition: ada-lang.c:12655
struct expression * excep_cond_expr
Definition: ada-lang.c:11993
const char * multiple_symbols_select_mode(void)
Definition: symtab.c:241
static struct type * new_type(char *)
Definition: mdebugread.c:4864
static struct type * ada_find_parallel_type_with_name(struct type *, const char *)
Definition: ada-lang.c:7867
static int return_match(struct type *func_type, struct type *context_type)
Definition: ada-lang.c:3588
static char * xget_renaming_scope(struct type *renaming_type)
Definition: ada-lang.c:5014
static struct type * ada_index_type(struct type *type, int n, const char *name)
Definition: ada-lang.c:2918
int dump_subexp(struct expression *exp, struct ui_file *stream, int elt)
Definition: expprint.c:728
static struct type * type_from_tag(struct value *tag)
Definition: ada-lang.c:6541
struct symbol * symbol
Definition: expression.h:66
#define BLOCK_FUNCTION(bl)
Definition: block.h:118
static int possible_user_operator_p(enum exp_opcode, struct value **)
static void initialize_ada_catchpoint_ops(void)
Definition: ada-lang.c:13841
void deprecated_set_value_type(struct value *value, struct type *type)
Definition: value.c:1026
static struct value * cast_from_fixed(struct type *type, struct value *arg)
Definition: ada-lang.c:9375
#define GROW_VECT(v, s, m)
Definition: ada-lang.h:160
struct type * ada_tag_type(struct value *val)
Definition: ada-lang.c:6493
static struct type * decode_constrained_packed_array_type(struct type *)
Definition: ada-lang.c:2213
struct type * type
Definition: expression.h:73
void set_value_address(struct value *value, CORE_ADDR addr)
Definition: value.c:1463
const char * symtab_to_fullname(struct symtab *s)
Definition: source.c:1131
static int is_ada95_tag(struct value *tag)
Definition: ada-lang.c:6502
static void cache_symbol(const char *name, domain_enum domain, struct symbol *sym, const struct block *block)
Definition: ada-lang.c:4547
static struct value * value_subscript_packed(struct value *, int, struct value **)
Definition: ada-lang.c:2316
void null_cleanup(void *arg)
Definition: cleanups.c:295
static void re_set_catch_exception(struct breakpoint *b)
Definition: ada-lang.c:12398
static struct value * unwrap_value(struct value *)
Definition: ada-lang.c:9320
int(* symbol_name_cmp_ftype)(const char *symbol_search_name, const char *lookup_name)
Definition: language.h:135
enum bpdisp disposition
Definition: breakpoint.h:673
struct value * evaluate_expression(struct expression *exp)
Definition: eval.c:159
#define TRY
static LONGEST ada_array_bound_from_type(struct type *arr_type, int n, int which)
Definition: ada-lang.c:2957
static void print_recreate_catch_assert(struct breakpoint *b, struct ui_file *fp)
Definition: ada-lang.c:12534
static int has_negatives(struct type *type)
Definition: ada-lang.c:2366
static enum print_stop_action print_it_catch_exception(bpstat bs)
Definition: ada-lang.c:12410
#define R(name, type, sim_num)
Definition: m32c-tdep.c:730
const struct block * block
Definition: expression.h:75
struct value * ada_coerce_to_simple_array_ptr(struct value *arr)
Definition: ada-lang.c:2023
static struct value * ada_index_struct_field_1(int *, struct value *, int, struct type *)
Definition: ada-lang.c:7197
struct value * value_ptradd(struct value *arg1, LONGEST arg2)
Definition: valarith.c:84
static struct type * ada_find_any_type(const char *name)
Definition: ada-lang.c:7661
void find_frame_sal(struct frame_info *frame, struct symtab_and_line *sal)
Definition: frame.c:2328
void ada_find_printable_frame(struct frame_info *fi)
Definition: ada-lang.c:11832
int discrete_position(struct type *type, LONGEST val, LONGEST *pos)
Definition: gdbtypes.c:1022
struct cmd_list_element * setlist
Definition: cli-cmds.c:135
const char *const name
Definition: aarch64-tdep.c:68
static int is_thick_pntr(struct type *type)
Definition: ada-lang.c:1619
static void lim_warning(const char *format,...) ATTRIBUTE_PRINTF(1
Definition: ada-lang.c:725
#define SYMTAB_BLOCKVECTOR(symtab)
Definition: symtab.h:968
#define ALL_OBJFILES(obj)
Definition: objfiles.h:579
static void ada_add_standard_exceptions(regex_t *preg, VEC(ada_exc_info)**exceptions)
Definition: ada-lang.c:13030
void ada_error(char *)
struct value * value_struct_elt(struct value **argp, struct value **args, const char *name, int *static_memfuncp, const char *err)
Definition: valops.c:2128
static CORE_ADDR ada_unhandled_exception_name_addr_from_raise(void)
Definition: ada-lang.c:11863
#define VEC_iterate(T, V, I, P)
Definition: vec.h:165
static char * ada_exception_catchpoint_cond_string(const char *excep_string)
Definition: ada-lang.c:12710
char * command_line_input(const char *, int, char *)
Definition: top.c:1024
ada_renaming_category
Definition: ada-lang.h:94
struct bp_location * next
Definition: breakpoint.h:307
char * ada_main_name(void)
Definition: ada-lang.c:911
struct type * check_typedef(struct type *type)
Definition: gdbtypes.c:2217
#define TYPE_GNU_IFUNC(t)
Definition: gdbtypes.h:318
#define SYMBOL_VALUE_ADDRESS(symbol)
Definition: symtab.h:182
static void emit_char(int c, struct type *type, struct ui_file *stream, int quoter)
Definition: ada-lang.c:13715
static struct value * ada_evaluate_subexp(struct type *, struct expression *, int *, enum noside)
Definition: ada-lang.c:10183
void ada_fixup_array_indexes_type(struct type *index_desc_type)
Definition: ada-lang.c:1502
static struct value * coerce_unspec_val_to_type(struct value *, struct type *)
Definition: ada-lang.c:668
const gdb_byte * value_contents(struct value *value)
Definition: value.c:1329
static int lesseq_defined_than(struct symbol *, struct symbol *)
Definition: ada-lang.c:4657
#define CATCH(EXCEPTION, MASK)
int contained_in(const struct block *a, const struct block *b)
Definition: block.c:73
static struct cmd_list_element * maint_set_ada_cmdlist
Definition: ada-lang.c:346
static void print_mention_catch_assert(struct breakpoint *b)
Definition: ada-lang.c:12528
static struct ada_pspace_data * get_ada_pspace_data(struct program_space *pspace)
Definition: ada-lang.c:454
static int find_struct_field(const char *, struct type *, int, struct type **, int *, int *, int *, int *)
Definition: ada-lang.c:7033
#define TYPE_MAIN_TYPE(thistype)
Definition: gdbtypes.h:1226
struct type * bool_type_default
Definition: language.h:125
static void ada_forward_operator_length(struct expression *, int, int *, int *)
Definition: ada-lang.c:13362
struct symbol * sym
Definition: ada-lang.c:280
static int ada_same_array_size_p(struct type *t1, struct type *t2)
Definition: ada-lang.c:9387
static int full_match(const char *, const char *)
Definition: ada-lang.c:5965
static const char * fixed_type_info(struct type *type)
Definition: ada-lang.c:11218
#define SYMBOL_DOMAIN(symbol)
Definition: symtab.h:790
int ada_prefer_type(struct type *type0, struct type *type1)
Definition: ada-lang.c:7759
void initialize_file_ftype(void)
Definition: defs.h:281
int value_lazy(struct value *value)
Definition: value.c:1305
struct bp_location * bp_location_at
Definition: breakpoint.h:1089
LONGEST ada_discrete_type_high_bound(struct type *type)
Definition: ada-lang.c:795
static int remove_irrelevant_renamings(struct ada_symbol_info *syms, int nsyms, const struct block *current_block)
Definition: ada-lang.c:5154
struct type * alloc_type_copy(const struct type *type)
Definition: gdbtypes.c:220
static enum ada_renaming_category parse_old_style_renaming(struct type *, const char **, int *, const char **)
Definition: ada-lang.c:4208
void fprintf_filtered(struct ui_file *stream, const char *format,...)
Definition: utils.c:2351
ULONGEST ada_modulus(struct type *type)
Definition: ada-lang.c:11547
static int encoded_ordered_before(const char *N0, const char *N1)
Definition: ada-lang.c:3671
int value_bitsize(const struct value *value)
Definition: value.c:1054
static unsigned int align_value(unsigned int off, unsigned int alignment)
Definition: ada-lang.c:7605
void * xzalloc(size_t size)
Definition: common-utils.c:91
#define SYMTAB_OBJFILE(symtab)
Definition: symtab.h:970
int ada_is_tagged_type(struct type *type, int refok)
Definition: ada-lang.c:6467
static ULONGEST umax_of_size(int size)
Definition: ada-lang.c:766
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:12807
static long decode_packed_array_bitsize(struct type *)
Definition: ada-lang.c:2115
const struct block * get_frame_block(struct frame_info *frame, CORE_ADDR *addr_in_block)
Definition: blockframe.c:55
int ada_name_prefix_len(const char *name)
Definition: ada-lang.c:634
int ada_is_simple_array_type(struct type *type)
Definition: ada-lang.c:1893
static void sort_remove_dups_ada_exceptions_list(VEC(ada_exc_info)**exceptions, int skip)
Definition: ada-lang.c:12976
struct value * value_cast_pointers(struct type *type, struct value *arg2, int subclass_check)
Definition: valops.c:306
static struct type * find_parallel_type_by_descriptive_type(struct type *type, const char *name)
Definition: ada-lang.c:7806
static int is_lower_alphanum(const char c)
Definition: ada-lang.c:1057
static const struct op_print ada_op_print_tab[]
Definition: ada-lang.c:13607
static struct symbol * find_old_style_renaming_symbol(const char *, const struct block *)
Definition: ada-lang.c:7700
static int scalar_type_p(struct type *)
Definition: ada-lang.c:4012
struct cleanup * compile_rx_or_error(regex_t *pattern, const char *rx, const char *message)
Definition: utils.c:1163
static struct htab * decoded_names_store
Definition: ada-lang.c:1396
void fprintf_unfiltered(struct ui_file *stream, const char *format,...)
Definition: utils.c:2361
static void info_exceptions_command(char *regexp, int from_tty)
Definition: ada-lang.c:13230
struct cmd_list_element * showlist
Definition: cli-cmds.c:143
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:7991
static void add_symbols_from_enclosing_procs(struct obstack *obstackp, const char *name, domain_enum domain, int wild_match_p)
Definition: ada-lang.c:4801
const gdb_byte * value_contents_all(struct value *value)
Definition: value.c:1188
static LONGEST max_of_type(struct type *t)
Definition: ada-lang.c:775
void fputs_filtered(const char *linebuffer, struct ui_file *stream)
Definition: utils.c:2145
double DOUBLEST
Definition: doublest.h:24
struct expression * parse_exp_1(const char **, CORE_ADDR pc, const struct block *, int)
Definition: parse.c:1109
static int should_use_wild_match(const char *lookup_name)
Definition: ada-lang.c:4593
int streq(const char *lhs, const char *rhs)
Definition: utils.c:2656
int ada_is_system_address_type(struct type *type)
Definition: ada-lang.c:11249
void set_value_parent(struct value *value, struct value *parent)
Definition: value.c:1073
#define ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS
Definition: ada-lang.h:53
int is_integral_type(struct type *t)
Definition: gdbtypes.c:2690
const char * bool_type_symbol
Definition: language.h:123
struct symbol * arg_sym
Definition: ada-lang.c:5287
void free_current_contents(void *ptr)
Definition: utils.c:476
const struct sym_fns * sf
Definition: objfiles.h:347
void unop_promote(const struct language_defn *language, struct gdbarch *gdbarch, struct value **arg1)
Definition: eval.c:433
static unsigned int varsize_limit
Definition: ada-lang.c:311
const struct exception_support_info * exception_info
Definition: ada-lang.c:385
int default_pass_by_reference(struct type *type)
Definition: language.c:659
struct type * value_enclosing_type(struct value *value)
Definition: value.c:1098
static struct ada_inferior_data * get_ada_inferior_data(struct inferior *inf)
Definition: ada-lang.c:411
static int desc_bound_bitsize(struct type *, int, int)
Definition: ada-lang.c:1826
enum bfd_endian gdbarch_byte_order(struct gdbarch *gdbarch)
Definition: gdbarch.c:1420
#define VEC_length(T, V)
Definition: vec.h:124
struct type * basic_lookup_transparent_type(const char *name)
Definition: symtab.c:2851
struct cleanup * make_cleanup(make_cleanup_ftype *function, void *arg)
Definition: cleanups.c:117
static struct cmd_list_element * set_ada_list
Definition: ada-lang.c:13819
static void ada_add_block_symbols(struct obstack *, const struct block *, const char *, domain_enum, struct objfile *, int)
Definition: ada-lang.c:5977
static void add_component_interval(LONGEST, LONGEST, LONGEST *, int *, int)
Definition: ada-lang.c:9872
#define CATCH_PERMANENT
Definition: breakpoint.h:1246
#define ALL_COMPUNITS(objfile, cu)
Definition: objfiles.h:616
#define TARGET_CHAR_BIT
Definition: host-defs.h:29
static void ada_free_symbol_cache(struct ada_symbol_cache *sym_cache)
Definition: ada-lang.c:4468
static int ada_is_packed_array_type(struct type *)
Definition: ada-lang.c:2080
struct type * ada_find_parallel_type(struct type *type, const char *suffix)
Definition: ada-lang.c:7883
Definition: gdbtypes.h:749
const char * word
Definition: symtab.h:1448
static void aggregate_assign_from_choices(struct value *, struct value *, struct expression *, int *, LONGEST *, int *, int, LONGEST, LONGEST)
Definition: ada-lang.c:9762
static void ada_language_arch_info(struct gdbarch *, struct language_arch_info *)
Definition: ada-lang.c:13659
static DOUBLEST scaling_factor(struct type *type)
Definition: ada-lang.c:11279
static struct symbol * standard_lookup(const char *, const struct block *, domain_enum)
Definition: ada-lang.c:4602
static int is_package_name(const char *name)
Definition: ada-lang.c:5048
const struct block * block_found
Definition: symtab.c:250
struct cache_entry * root[HASH_SIZE]
Definition: ada-lang.c:305
const struct block * block
Definition: ada-lang.c:283
#define BLOCK_SUPERBLOCK(bl)
Definition: block.h:119
char string
Definition: expression.h:72
int ada_is_wrapper_field(struct type *type, int field_num)
Definition: ada-lang.c:6793
struct gdbarch * get_type_arch(const struct type *type)
Definition: gdbtypes.c:232
static int compare_ada_exception_info(const void *a, const void *b)
Definition: ada-lang.c:12952
static int ada_is_unconstrained_packed_array_type(struct type *)
Definition: ada-lang.c:2105
struct cmd_list_element * add_info(const char *name, cmd_cfunc_ftype *fun, const char *doc)
Definition: cli-decode.c:857
Definition: gnu-nat.c:163
struct gdbarch * get_current_arch(void)
Definition: arch-utils.c:781
gdb_byte * value_contents_writeable(struct value *value)
Definition: value.c:1338
static LONGEST min_of_type(struct type *t)
Definition: ada-lang.c:785
struct type * ada_type_of_array(struct value *arr, int bounds)
Definition: ada-lang.c:1944
struct value * value_assign(struct value *toval, struct value *fromval)
Definition: valops.c:993
static const char * type
Definition: language.c:103
int dump_subexp_body_standard(struct expression *exp, struct ui_file *stream, int elt)
Definition: expprint.c:762
#define gdb_assert(expr)
Definition: gdb_assert.h:33
struct type * language_bool_type(const struct language_defn *la, struct gdbarch *gdbarch)
Definition: language.c:966
static struct type * desc_bounds_type(struct type *)
Definition: ada-lang.c:1630
int gdbarch_double_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1624
struct value * value_from_longest(struct type *type, LONGEST num)
Definition: value.c:3464
#define SYMBOL_LINE(symbol)
Definition: symtab.h:800
#define SYMBOL_LINKAGE_NAME(symbol)
Definition: symtab.h:241
void exception_fprintf(struct ui_file *file, struct gdb_exception e, const char *prefix,...)
Definition: exceptions.c:119
static struct bp_location * allocate_location_catch_exception_unhandled(struct breakpoint *self)
Definition: ada-lang.c:12444
static int startswith(const char *string, const char *pattern)
Definition: common-utils.h:75
static LONGEST ada_array_bound(struct value *arr, int n, int which)
Definition: ada-lang.c:3013
static int ada_value_equal(struct value *arg1, struct value *arg2)
Definition: ada-lang.c:9553
void set_value_offset(struct value *value, int offset)
Definition: value.c:1037
struct value * value_at_lazy(struct type *type, CORE_ADDR addr)
Definition: valops.c:951
static void aggregate_assign_others(struct value *, struct value *, struct expression *, int *, LONGEST *, int, LONGEST, LONGEST)
Definition: ada-lang.c:9844
void expand_symtabs_matching(expand_symtabs_file_matcher_ftype *file_matcher, expand_symtabs_symbol_matcher_ftype *symbol_matcher, expand_symtabs_exp_notify_ftype *expansion_notify, enum search_domain kind, void *data)
Definition: symfile.c:3917
struct value * value_cast(struct type *type, struct value *arg2)
Definition: valops.c:351
int found_sym
Definition: ada-lang.c:5288
static int match_name(const char *sym_name, const char *name, int wild)
Definition: ada-lang.c:1457
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:8324
static VEC(char_ptr)
Definition: ada-lang.c:6267
char * ada_name_for_lookup(const char *name)
Definition: ada-lang.c:5616
int ada_is_array_descriptor_type(struct type *type)
Definition: ada-lang.c:1907
struct type * tsd_type
Definition: ada-lang.c:380
char * xstrprintf(const char *format,...)
Definition: common-utils.c:107
static struct type * template_to_static_fixed_type(struct type *type0)
Definition: ada-lang.c:8255
#define NULL_TYPE
Definition: gdbtypes.h:814
struct type * arch_integer_type(struct gdbarch *gdbarch, int bit, int unsigned_p, char *name)
Definition: gdbtypes.c:4552
#define VEC_alloc(T, N)
Definition: vec.h:173
int deprecated_value_modifiable(struct value *value)
Definition: value.c:1490
void printf_unfiltered(const char *format,...)
Definition: utils.c:2399
static void symbol_completion_add(VEC(char_ptr)**sv, const char *sym_name, const char *text, int text_len, const char *orig_text, const char *word, int wild_match_p, int encoded_p)
Definition: ada-lang.c:6201
#define TRUNCATION_TOWARDS_ZERO
Definition: ada-lang.c:68
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:8714
static char * ada_completer_word_break_characters
Definition: ada-lang.c:315
static enum print_stop_action print_it_exception(enum ada_exception_catchpoint_kind ex, bpstat bs)
Definition: ada-lang.c:12190
#define TYPE_FIELDS(thistype)
Definition: gdbtypes.h:1242
static symbol_name_cmp_ftype ada_get_symbol_name_cmp(const char *lookup_name)
Definition: ada-lang.c:13740
static void maint_show_ada_cmd(char *args, int from_tty)
Definition: ada-lang.c:361
void read_memory(CORE_ADDR memaddr, gdb_byte *myaddr, ssize_t len)
Definition: corefile.c:244
char * op_name_standard(enum exp_opcode opcode)
Definition: expprint.c:662
struct bp_location base
Definition: ada-lang.c:11988
Definition: symtab.h:925
#define ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS
Definition: ada-lang.h:45
static struct value * empty_array(struct type *arr_type, int low)
Definition: ada-lang.c:3079
static unsigned int field_alignment(struct type *type, int f)
Definition: ada-lang.c:7613
static struct value * ada_read_renaming_var_value(struct symbol *renaming_sym, const struct block *block)
Definition: ada-lang.c:4267
static char encoding[]
Definition: remote-mips.c:2988
struct value * value_from_double(struct type *type, DOUBLEST num)
Definition: value.c:3563
const char * objfile_name(const struct objfile *objfile)
Definition: objfiles.c:1499
int value_equal(struct value *arg1, struct value *arg2)
Definition: valarith.c:1574
static const struct inferior_data * ada_inferior_data
Definition: ada-lang.c:389
struct breakpoint_ops bkpt_breakpoint_ops
Definition: breakpoint.c:313
void * xmalloc(YYSIZE_T)
struct symtab * symtab
Definition: symtab.h:1369
static int fat_pntr_data_bitpos(struct type *)
Definition: ada-lang.c:1781
unsigned int msymbol_hash(const char *string)
Definition: minsyms.c:102
struct ada_symbol_cache * sym_cache
Definition: ada-lang.c:442
void set_value_bitsize(struct value *value, int bit)
Definition: value.c:1059
static const char * symbol_completion_match(const char *sym_name, const char *text, int text_len, int wild_match_p, int encoded_p)
Definition: ada-lang.c:6110
char * excep_string
Definition: ada-lang.c:12024
int ada_lookup_symbol_list(const char *name0, const struct block *block0, domain_enum domain, struct ada_symbol_info **results)
Definition: ada-lang.c:5582
static int variant_field_index(struct type *type)
Definition: ada-lang.c:7941
#define TYPE_FIELD_BITSIZE(thistype, n)
Definition: gdbtypes.h:1377
#define EXP_ELEM_TO_BYTES(elements)
Definition: expression.h:91
void ada_value_print(struct value *, struct ui_file *, const struct value_print_options *)
struct type * builtin_bool
Definition: gdbtypes.h:1496
static int ada_is_dispatch_table_ptr_type(struct type *type)
Definition: ada-lang.c:6395
static void catch_assert_command(char *arg, int from_tty, struct cmd_list_element *command)
Definition: ada-lang.c:12888
struct symbol * sym
Definition: ada-lang.h:87
struct type * ada_get_decoded_type(struct type *type)
Definition: ada-lang.c:881
struct value * ada_value_subscript(struct value *arr, int arity, struct value **ind)
Definition: ada-lang.c:2732
struct type * lookup_struct_elt_type(struct type *type, const char *name, int noerr)
Definition: gdbtypes.c:1558
static char * ada_tag_name_from_tsd(struct value *tsd)
Definition: ada-lang.c:6688
void cmd_show_list(struct cmd_list_element *list, int from_tty, const char *prefix)
Definition: cli-setshow.c:672
void(* check_status)(struct bpstats *bs)
Definition: breakpoint.h:536
#define TYPE_FIELD_BITPOS(thistype, n)
Definition: gdbtypes.h:1371
enum ada_renaming_category ada_parse_renaming(struct symbol *sym, const char **renamed_entity, int *len, const char **renaming_expr)
Definition: ada-lang.c:4143
static int ada_is_redundant_index_type_desc(struct type *array_type, struct type *desc_type)
Definition: ada-lang.c:8535
static void print_one_catch_assert(struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:12522
int ada_is_constrained_packed_array_type(struct type *type)
Definition: ada-lang.c:2095
#define TYPE_UNSIGNED(t)
Definition: gdbtypes.h:233
static void dtor_catch_exception_unhandled(struct breakpoint *b)
Definition: ada-lang.c:12438
static int ada_is_interface_tag(struct type *type)
Definition: ada-lang.c:6412
#define SYMBOL_VALUE(symbol)
Definition: symtab.h:181
const char * name
Definition: symtab.h:98
static void ada_new_objfile_observer(struct objfile *objfile)
Definition: ada-lang.c:13884
static void re_set_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:12122
struct value * ada_tag_value_at_base_address(struct value *obj)
Definition: ada-lang.c:6557
#define DOUBLEST_SCAN_FORMAT
Definition: doublest.h:55
int ada_is_tag_type(struct type *type)
Definition: ada-lang.c:6475
Definition: block.h:60
Definition: value.c:172
static struct value * decode_constrained_packed_array(struct value *)
Definition: ada-lang.c:2261
static struct value * ada_to_fixed_value_create(struct type *, CORE_ADDR, struct value *)
Definition: ada-lang.c:8977
int ptid_get_pid(ptid_t ptid)
Definition: ptid.c:52
int ada_scan_number(const char str[], int k, LONGEST *R, int *new_k)
Definition: ada-lang.c:6903
static void dtor_catch_exception(struct breakpoint *b)
Definition: ada-lang.c:12386
static LONGEST max_of_size(int size)
Definition: ada-lang.c:750
void print_recreate_thread(struct breakpoint *b, struct ui_file *fp)
Definition: breakpoint.c:15272
LONGEST ada_discrete_type_low_bound(struct type *type)
Definition: ada-lang.c:816
static int ada_is_array_type(struct type *type)
Definition: ada-lang.c:1881
struct symbol * block_iter_match_next(const char *name, symbol_compare_ftype *compare, struct block_iterator *iterator)
Definition: block.c:712
static char * ada_get_gdb_completer_word_break_characters(void)
Definition: ada-lang.c:556
struct breakpoint * breakpoint_at
Definition: breakpoint.h:1095
struct symbol * ada_lookup_symbol(const char *name, const struct block *block0, domain_enum domain, int *is_a_field_of_this)
Definition: ada-lang.c:5665
static LONGEST pos_atr(struct value *)
Definition: ada-lang.c:9037
#define SYMBOL_OBJFILE_OWNED(symbol)
Definition: symtab.h:794
int ada_is_fixed_point_type(struct type *type)
Definition: ada-lang.c:11241
#define LA_PRINT_TYPE(type, varstring, stream, show, level, flags)
Definition: language.h:482
PTR xrealloc(PTR ptr, size_t size)
Definition: common-utils.c:51
int ada_which_variant_applies(struct type *var_type, struct type *outer_type, const gdb_byte *outer_valaddr)
Definition: ada-lang.c:7496
static struct obstack symbol_list_obstack
Definition: ada-lang.c:342
#define VEC_truncate(T, V, I)
Definition: vec.h:278
print_stop_action
Definition: breakpoint.h:476
static void ada_init_symbol_cache(struct ada_symbol_cache *sym_cache)
Definition: ada-lang.c:4459
int ada_is_ignored_field(struct type *type, int field_num)
Definition: ada-lang.c:6426
static int numeric_type_p(struct type *)
Definition: ada-lang.c:3967
ada_unhandled_exception_name_addr_ftype * unhandled_exception_name_addr
Definition: ada-lang.c:11623
static int warning_limit
Definition: ada-lang.c:327
#define COMPUNIT_BLOCKVECTOR(cust)
Definition: symtab.h:1099
struct symbol * fixup_symbol_section(struct symbol *sym, struct objfile *objfile)
Definition: symtab.c:1809
static void assign_component(struct value *container, struct value *lhs, LONGEST index, struct expression *exp, int *pos)
Definition: ada-lang.c:9614
static int ada_dump_subexp_body(struct expression *exp, struct ui_file *stream, int elt)
Definition: ada-lang.c:13399
const char const char int
Definition: command.h:229
bfd_byte gdb_byte
Definition: common-types.h:38
static struct bp_location * allocate_location_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *self)
Definition: ada-lang.c:12107
int ada_array_arity(struct type *type)
Definition: ada-lang.c:2845
static void aggregate_assign_positional(struct value *, struct value *, struct expression *, int *, LONGEST *, int *, int, LONGEST, LONGEST)
Definition: ada-lang.c:9737
static struct value * ada_coerce_ref(struct value *)
Definition: ada-lang.c:7584
static char * ada_la_decode(const char *encoded, int options)
Definition: ada-lang.c:1444
#define MSYMBOL_TYPE(msymbol)
Definition: symtab.h:382
void help_list(struct cmd_list_element *list, const char *cmdtype, enum command_class theclass, struct ui_file *stream)
Definition: cli-decode.c:1023
static const struct exception_support_info default_exception_support_info
Definition: ada-lang.c:11633
enum language ada_update_initial_language(enum language lang)
Definition: ada-lang.c:897
void discard_cleanups(struct cleanup *old_chain)
Definition: cleanups.c:213
int strcmp_iw_ordered(const char *string1, const char *string2)
Definition: utils.c:2576
#define ALL_MSYMBOLS(objfile, m)
Definition: objfiles.h:623
static int compare_names_with_case(const char *string1, const char *string2, enum case_sensitivity casing)
Definition: ada-lang.c:5335
#define TYPE_TARGET_TYPE(thistype)
Definition: gdbtypes.h:1229
static void print_one_catch_exception(struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:12416
void gdb_print_host_address(const void *addr, struct ui_file *stream)
Definition: utils.c:1106
struct type * builtin_double
Definition: gdbtypes.h:1491
struct value * value_neg(struct value *arg1)
Definition: valarith.c:1767
static char * bound_name[]
Definition: ada-lang.c:1535
struct type * ada_aligned_type(struct type *type)
Definition: ada-lang.c:9209
static struct value * desc_data(struct value *)
Definition: ada-lang.c:1763
void install_breakpoint(int internal, struct breakpoint *b, int update_gll)
Definition: breakpoint.c:8456
static CORE_ADDR cond_offset_target(CORE_ADDR address, long offset)
Definition: ada-lang.c:707
void print_subexp_standard(struct expression *exp, int *pos, struct ui_file *stream, enum precedence prec)
Definition: expprint.c:58
static struct value * ada_get_tsd_from_tag(struct value *tag)
Definition: ada-lang.c:6652
void print_subexp(struct expression *exp, int *pos, struct ui_file *stream, enum precedence prec)
Definition: expprint.c:49
const char * async_reason_lookup(enum async_reply_reason reason)
Definition: mi-common.c:49
static const struct program_space_data * ada_pspace_data_handle
Definition: ada-lang.c:446
int xsnprintf(char *str, size_t size, const char *format,...)
Definition: common-utils.c:134
#define ADA_OPERATORS
Definition: ada-lang.c:13258
CORE_ADDR parse_and_eval_address(const char *exp)
Definition: eval.c:96
static struct type * to_static_fixed_type(struct type *)
Definition: ada-lang.c:8862
static struct cache_entry ** find_entry(const char *name, domain_enum domain)
Definition: ada-lang.c:4507
const struct block * block_static_block(const struct block *block)
Definition: block.c:365
#define TYPE_CODE(thistype)
Definition: gdbtypes.h:1240
#define TYPE_INDEX_TYPE(type)
Definition: gdbtypes.h:1244
void modify_field(struct type *type, gdb_byte *addr, LONGEST fieldval, int bitpos, int bitsize)
Definition: value.c:3345
static struct cmd_list_element * maint_show_ada_cmdlist
Definition: ada-lang.c:347
static int ada_is_non_standard_exception_sym(struct symbol *sym)
Definition: ada-lang.c:12925
struct type * resolve_dynamic_type(struct type *type, const gdb_byte *valaddr, CORE_ADDR addr)
Definition: gdbtypes.c:2143
static enum print_stop_action print_it_catch_exception_unhandled(bpstat bs)
Definition: ada-lang.c:12462
precedence
Definition: parser-defs.h:303
struct value * value_of_variable(struct symbol *var, const struct block *b)
Definition: valops.c:1291
static struct type * desc_index_type(struct type *, int)
Definition: ada-lang.c:1840
struct ui_file * gdb_stderr
Definition: main.c:72
static struct value * ada_index_struct_field(int, struct value *, int, struct type *)
Definition: ada-lang.c:7185
#define TYPE_FIXED_INSTANCE(t)
Definition: gdbtypes.h:299
ptid_t inferior_ptid
Definition: infcmd.c:124
struct type * builtin_data_ptr
Definition: gdbtypes.h:1533
static void catch_ada_assert_command_split(char *args, char **cond_string)
Definition: ada-lang.c:12864
struct minimal_symbol * minsym
Definition: minsyms.h:32
const char * ada_type_name(struct type *type)
Definition: ada-lang.c:7792
static struct value * ada_value_ptr_subscript(struct value *arr, int arity, struct value **ind)
Definition: ada-lang.c:2759
int gdbarch_long_long_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1524
static void ada_clear_symbol_cache(void)
Definition: ada-lang.c:4494
struct gdbarch * block_gdbarch(const struct block *block)
Definition: block.c:60
static struct type * ada_get_tsd_type(struct inferior *inf)
Definition: ada-lang.c:6637
int ada_parse(struct parser_state *par_state)
Definition: ada-exp.c:2751
struct bp_location * loc
Definition: breakpoint.h:678
LONGEST ada_float_to_fixed(struct type *type, DOUBLEST x)
Definition: ada-lang.c:11315
static void ada_catchpoint_location_dtor(struct bp_location *bl)
Definition: ada-lang.c:12000
static void ada_add_global_exceptions(regex_t *preg, VEC(ada_exc_info)**exceptions)
Definition: ada-lang.c:13118
int operator_check_standard(struct expression *exp, int pos, int(*objfile_func)(struct objfile *objfile, void *data), void *data)
Definition: parse.c:1782
struct value * ada_coerce_to_simple_array(struct value *arr)
Definition: ada-lang.c:2044
void get_user_print_options(struct value_print_options *opts)
Definition: valprint.c:129
int offset
Definition: agent.c:65
static char * ada_op_name(enum exp_opcode)
Definition: ada-lang.c:13337
static int desc_arity(struct type *)
Definition: ada-lang.c:1854
int code
Definition: ser-unix.c:684
int value_less(struct value *arg1, struct value *arg2)
Definition: valarith.c:1673
int ada_is_variant_part(struct type *type, int field_num)
Definition: ada-lang.c:6809
static int ada_identical_enum_types_p(struct type *type1, struct type *type2)
Definition: ada-lang.c:4826
#define TYPE_NFIELDS(thistype)
Definition: gdbtypes.h:1241
static void ada_exception_support_info_sniffer(void)
Definition: ada-lang.c:11713
ada_exception_catchpoint_kind
Definition: ada-lang.h:118
static CORE_ADDR ada_exception_name_addr_1(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:11912
Definition: buffer.h:23
unsigned int ada_mangled
Definition: symtab.h:155
static void check_status_catch_assert(bpstat bs)
Definition: ada-lang.c:12510
int gdbarch_float_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1591
#define qsort
Definition: ada-exp.c:2747
struct value * evaluate_subexp(struct type *expect_type, struct expression *exp, int *pos, enum noside noside)
Definition: eval.c:64
struct value * ada_value_ind(struct value *val0)
Definition: ada-lang.c:7570
#define SYMBOL_LANGUAGE(symbol)
Definition: symtab.h:187
char * ada_variant_discrim_name(struct type *type0)
Definition: ada-lang.c:6849
exp_opcode
Definition: expression.h:43
DOUBLEST ada_delta(struct type *type)
Definition: ada-lang.c:11260
static struct value * ada_promote_array_of_integrals(struct type *type, struct value *val)
Definition: ada-lang.c:9415
static int is_nondebugging_type(struct type *type)
Definition: ada-lang.c:4811
#define VEC_address(T, V)
Definition: vec.h:369
struct value * ada_value_tag(struct value *val)
Definition: ada-lang.c:6510
void ada_val_print(struct type *, const gdb_byte *, int, CORE_ADDR, struct ui_file *, int, const struct value *, const struct value_print_options *)
#define CHECK_TYPEDEF(TYPE)
Definition: gdbtypes.h:1817
int symbol_matches_domain(enum language symbol_language, domain_enum symbol_domain, domain_enum domain)
Definition: symtab.c:2758
static int ada_exc_search_name_matches(const char *search_name, void *user_data)
Definition: ada-lang.c:13006
struct value * evaluate_subexp_standard(struct type *expect_type, struct expression *exp, int *pos, enum noside noside)
Definition: eval.c:699
struct value * value_binop(struct value *arg1, struct value *arg2, enum exp_opcode op)
Definition: valarith.c:1476
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:523
static struct value * ada_value_slice_from_ptr(struct value *array_ptr, struct type *type, int low, int high)
Definition: ada-lang.c:2788
#define TYPE_TAG_NAME(type)
Definition: gdbtypes.h:1228
LONGEST longconst
Definition: expression.h:67
struct bound_minimal_symbol ada_lookup_simple_minsym(const char *name)
Definition: ada-lang.c:4761
struct type * ada_array_element_type(struct type *type, int nindices)
Definition: ada-lang.c:2873
void * grow_vect(void *vect, size_t *size, size_t min_size, int element_size)
Definition: ada-lang.c:576
void operator_length_standard(const struct expression *expr, int endpos, int *oplenp, int *argsp)
Definition: parse.c:859
#define TYPE_STUB(t)
Definition: gdbtypes.h:245
int ada_is_modular_type(struct type *type)
Definition: ada-lang.c:11535
static int is_name_suffix(const char *)
Definition: ada-lang.c:5735
static void ada_free_objfile_observer(struct objfile *objfile)
Definition: ada-lang.c:13892
struct inferior * current_inferior(void)
Definition: inferior.c:57
static int is_thin_pntr(struct type *type)
Definition: ada-lang.c:1571
const struct block * get_selected_block(CORE_ADDR *addr_in_block)
Definition: stack.c:2230
static const struct breakpoint_ops * ada_exception_breakpoint_ops(enum ada_exception_catchpoint_kind ex)
Definition: ada-lang.c:12682
const char * ada_decode_symbol(const struct general_symbol_info *arg)
Definition: ada-lang.c:1409
char shlib_disabled
Definition: breakpoint.h:365
#define SYMBOL_NATURAL_NAME(symbol)
Definition: symtab.h:231
static struct value * coerce_for_assign(struct type *type, struct value *val)
Definition: ada-lang.c:9453
EXTERN_C char * re_comp(const char *)
static int fat_pntr_data_bitsize(struct type *)
Definition: ada-lang.c:1790
struct program_space * current_program_space
Definition: progspace.c:35
static void add_defn_to_vec(struct obstack *, struct symbol *, const struct block *)
Definition: ada-lang.c:4695
static struct value * thin_data_pntr(struct value *val)
Definition: ada-lang.c:1603
void ui_out_field_core_addr(struct ui_out *uiout, const char *fldname, struct gdbarch *gdbarch, CORE_ADDR address)
Definition: ui-out.c:499
const char * ada_enum_name(const char *name)
Definition: ada-lang.c:9238
int gdbarch_bits_big_endian(struct gdbarch *gdbarch)
Definition: gdbarch.c:1456
unsigned long long ULONGEST
Definition: common-types.h:53
const char * catch_exception_sym
Definition: ada-lang.c:11609
static void ATTRIBUTE_PRINTF(6, 0)
Definition: cli-out.c:229
static CORE_ADDR value_pointer(struct value *value, struct type *type)
Definition: ada-lang.c:4378
static PyObject * field_name(struct type *type, int field)
Definition: py-type.c:278
language
Definition: defs.h:167
void initialize_breakpoint_ops(void)
Definition: breakpoint.c:15571
void(* map_matching_symbols)(struct objfile *, const char *name, domain_enum domain, int global, int(*callback)(struct block *, struct symbol *, void *), void *data, symbol_compare_ftype *match, symbol_compare_ftype *ordered_compare)
Definition: symfile.h:260
static int is_unchecked_variant(struct type *var_type, struct type *outer_type)
Definition: ada-lang.c:7481
struct value * value_allocate_space_in_inferior(int len)
Definition: valops.c:186
struct value * value_slice(struct value *array, int lowbound, int length)
Definition: valops.c:3774
struct gdbarch * gdbarch
Definition: expression.h:83
int is_dynamic_type(struct type *type)
Definition: gdbtypes.c:1852
int ada_is_aligner_type(struct type *type)
Definition: ada-lang.c:9145
static int symbols_are_identical_enums(struct ada_symbol_info *syms, int nsyms)
Definition: ada-lang.c:4882
#define VEC_cleanup(T)
Definition: vec.h:187
struct observer * observer_attach_new_objfile(observer_new_objfile_ftype *f)
static int is_dynamic_field(struct type *, int)
Definition: ada-lang.c:7928
void(* dtor)(struct breakpoint *self)
Definition: breakpoint.h:502
char stop
Definition: breakpoint.h:1107
static void move_bits(gdb_byte *, int, const gdb_byte *, int, int, int)
Definition: ada-lang.c:2564
struct type * value_type(const struct value *value)
Definition: value.c:1021
static void print_mention_catch_exception(struct breakpoint *b)
Definition: ada-lang.c:12422
static void set_ada_command(char *arg, int from_tty)
Definition: ada-lang.c:13825
static struct value * ada_value_binop(struct value *arg1, struct value *arg2, enum exp_opcode op)
Definition: ada-lang.c:9495
#define TYPE_ARRAY_LOWER_BOUND_VALUE(arraytype)
Definition: gdbtypes.h:1290
#define TYPE_ALLOC(t, size)
Definition: gdbtypes.h:1631
#define SYMBOL_TYPE(symbol)
Definition: symtab.h:799
static struct value * assign_aggregate(struct value *, struct value *, struct expression *, int *, enum noside)
Definition: ada-lang.c:9652
Definition: ia64-tdep.c:84
void ada_ensure_varsize_limit(const struct type *type)
Definition: ada-lang.c:742
static int scan_discrim_bound(char *str, int k, struct value *dval, LONGEST *px, int *pnew_k)
Definition: ada-lang.c:11331
Definition: symtab.h:703
struct value * ada_convert_actual(struct value *actual, struct type *formal_type0)
Definition: ada-lang.c:4315
static int fat_pntr_bounds_bitsize(struct type *)
Definition: ada-lang.c:1724
struct symbol * ada_find_renaming_symbol(struct symbol *name_sym, const struct block *block)
Definition: ada-lang.c:7678
static void ada_pspace_data_cleanup(struct program_space *pspace, void *data)
Definition: ada-lang.c:471
CORE_ADDR value_as_address(struct value *val)
Definition: value.c:2679
#define LA_VALUE_PRINT(val, stream, options)
Definition: language.h:491
void ui_out_field_string(struct ui_out *uiout, const char *fldname, const char *string)
Definition: ui-out.c:541
static void catch_ada_exception_command_split(char *args, enum ada_exception_catchpoint_kind *ex, char **excep_string, char **cond_string)
Definition: ada-lang.c:12584
static void re_set_catch_exception_unhandled(struct breakpoint *b)
Definition: ada-lang.c:12450
static int num_component_specs(struct expression *exp, int pc)
Definition: ada-lang.c:9584
static struct value * make_array_descriptor(struct type *, struct value *)
Definition: ada-lang.c:4399
static int num_defns_collected(struct obstack *)
Definition: ada-lang.c:4736
DOUBLEST ada_fixed_to_float(struct type *type, LONGEST x)
Definition: ada-lang.c:11306
struct value * ada_to_fixed_value(struct value *val)
Definition: ada-lang.c:8993
gdb_byte * value_contents_raw(struct value *value)
Definition: value.c:1084
void annotate_catchpoint(int num)
Definition: annotate.c:98
CORE_ADDR address
Definition: breakpoint.h:410
int ada_is_parent_field(struct type *type, int field_num)
Definition: ada-lang.c:6777
static struct value * cast_to_fixed(struct type *type, struct value *arg)
Definition: ada-lang.c:9354
static int is_suffix(const char *str, const char *suffix)
Definition: ada-lang.c:653
const char * type_name_no_tag(const struct type *type)
Definition: gdbtypes.c:1361
static struct bp_location * allocate_location_catch_exception(struct breakpoint *self)
Definition: ada-lang.c:12392
#define TYPE_LENGTH(thistype)
Definition: gdbtypes.h:1237
const char * encoded
Definition: ada-lang.h:73
struct objfile * objfile
Definition: minsyms.h:37
#define HOST_CHAR_BIT
Definition: host-defs.h:40
static int lookup_cached_symbol(const char *name, domain_enum domain, struct symbol **sym, const struct block **block)
Definition: ada-lang.c:4529
CORE_ADDR address
Definition: value.c:216
static struct breakpoint_ops catch_exception_breakpoint_ops
Definition: ada-lang.c:12433
static const char * ada_unqualified_name(const char *decoded_name)
Definition: ada-lang.c:522
static struct type * to_fixed_record_type(struct type *type0, const gdb_byte *valaddr, CORE_ADDR address, struct value *dval)
Definition: ada-lang.c:8406
static int ada_is_direct_array_type(struct type *)
Definition: ada-lang.c:1868
static void dtor_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:12094
struct type * arch_type(struct gdbarch *gdbarch, enum type_code code, int length, char *name)
Definition: gdbtypes.c:4532
static void re_set_catch_assert(struct breakpoint *b)
Definition: ada-lang.c:12504
void gdb_flush(struct ui_file *file)
Definition: ui-file.c:192
static int block_depth(struct block *)
Definition: symmisc.c:940
struct ui_out * current_uiout
Definition: ui-out.c:233
static struct value * desc_bounds(struct value *)
Definition: ada-lang.c:1660
char * op_string(enum exp_opcode op)
Definition: expprint.c:633
void void vwarning(const char *fmt, va_list args) ATTRIBUTE_PRINTF(1
static void ada_remove_po_subprogram_suffix(const char *encoded, int *len)
Definition: ada-lang.c:1098
void write_memory_with_notification(CORE_ADDR memaddr, const bfd_byte *myaddr, ssize_t len)
Definition: corefile.c:402
int value_true(struct value *val)
Definition: language.c:404
#define LANG_MAGIC
Definition: language.h:402
#define QUIT
Definition: defs.h:160
static void ada_inferior_exit(struct inferior *inf)
Definition: ada-lang.c:429
struct general_symbol_info::@159::mangled_lang mangled_lang
void write_memory(CORE_ADDR memaddr, const bfd_byte *myaddr, ssize_t len)
Definition: corefile.c:389
static struct value * value_tag_from_contents_and_address(struct type *type, const gdb_byte *valaddr, CORE_ADDR address)
Definition: ada-lang.c:6520
static struct symtab_and_line ada_exception_sal(enum ada_exception_catchpoint_kind ex, char *excep_string, char **addr_string, const struct breakpoint_ops **ops)
Definition: ada-lang.c:12755
const struct quick_symbol_functions * qf
Definition: symfile.h:398
struct gdbarch * gdbarch
Definition: breakpoint.h:396
const char * name
Definition: ada-lang.c:275
void ada_printchar(int, struct type *, struct ui_file *)
Definition: ada-valprint.c:349
static void dtor_catch_assert(struct breakpoint *b)
Definition: ada-lang.c:12492
CORE_ADDR value_address(const struct value *value)
Definition: value.c:1440
static void catch_ada_exception_command(char *arg, int from_tty, struct cmd_list_element *command)
Definition: ada-lang.c:12834
static struct type * desc_data_target_type(struct type *)
Definition: ada-lang.c:1740
int gdbarch_short_bit(struct gdbarch *gdbarch)
Definition: gdbarch.c:1473
#define TYPE_DESCRIPTIVE_TYPE(thistype)
Definition: gdbtypes.h:1322
Definition: defs.h:353
struct type ** primitive_type_vector
Definition: language.h:113
struct bound_minimal_symbol lookup_minimal_symbol(const char *name, const char *sfile, struct objfile *objf)
Definition: minsyms.c:163
PTR xcalloc(size_t number, size_t size)
Definition: common-utils.c:71
static struct value * resolve_subexp(struct expression **, int *, int, struct type *)
Definition: ada-lang.c:3141
static void print_mention_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b)
Definition: ada-lang.c:12312
struct symtab * symbol_symtab(const struct symbol *symbol)
Definition: symtab.c:6250
static struct type * dynamic_template_type(struct type *type)
Definition: ada-lang.c:7906
static int discrete_type_p(struct type *)
Definition: ada-lang.c:4034
struct symbol * block_iter_match_first(const struct block *block, const char *name, symbol_compare_ftype *compare, struct block_iterator *iterator)
Definition: block.c:695
struct cmd_list_element * maintenance_show_cmdlist
Definition: maint.c:647
int get_array_bounds(struct type *type, LONGEST *low_bound, LONGEST *high_bound)
Definition: gdbtypes.c:978
static void ada_inferior_data_cleanup(struct inferior *inf, void *arg)
Definition: ada-lang.c:393
#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype)
Definition: gdbtypes.h:1287
int target_read_string(CORE_ADDR memaddr, char **string, int len, int *errnop)
Definition: target.c:915
static void print_one_exception(enum ada_exception_catchpoint_kind ex, struct breakpoint *b, struct bp_location **last_loc)
Definition: ada-lang.c:12263
struct breakpoint * owner
Definition: breakpoint.h:324
struct type * builtin_void
Definition: gdbtypes.h:1480
int has_stack_frames(void)
Definition: frame.c:1506
static struct type * get_base_type(struct type *type)
Definition: ada-lang.c:839
void(* print_one)(struct breakpoint *, struct bp_location **)
Definition: breakpoint.h:554
case_sensitivity
Definition: language.h:88
int get_discrete_bounds(struct type *type, LONGEST *lowp, LONGEST *highp)
Definition: gdbtypes.c:899
static int ada_operator_check(struct expression *exp, int pos, int(*objfile_func)(struct objfile *objfile, void *data), void *data)
Definition: ada-lang.c:13309
const char multiple_symbols_all[]
Definition: symtab.c:227
void error(const char *fmt,...)
Definition: errors.c:38
size_t size
Definition: go32-nat.c:242
DOUBLEST value_as_double(struct value *val)
Definition: value.c:2664
void(* re_set)(struct breakpoint *self)
Definition: breakpoint.h:510
void gdbarch_address_to_pointer(struct gdbarch *gdbarch, struct type *type, gdb_byte *buf, CORE_ADDR addr)
Definition: gdbarch.c:2498
void set_breakpoint_condition(struct breakpoint *b, const char *exp, int from_tty)
Definition: breakpoint.c:960
#define skip_to_space(INP)
Definition: common-utils.h:94
#define ALL_BLOCK_SYMBOLS(block, iter, sym)
Definition: block.h:333
struct type * lookup_pointer_type(struct type *type)
Definition: gdbtypes.c:368
static struct ada_symbol_cache * ada_get_symbol_cache(struct program_space *pspace)
Definition: ada-lang.c:4478
static struct type * ada_typedef_target_type(struct type *type)
Definition: ada-lang.c:510
long long LONGEST
Definition: common-types.h:52
static void add_nonlocal_symbols(struct obstack *obstackp, const char *name, domain_enum domain, int global, int is_wild_match)
Definition: ada-lang.c:5421
static struct symbol * ada_find_any_type_symbol(const char *name)
Definition: ada-lang.c:7644
void do_cleanups(struct cleanup *old_chain)
Definition: cleanups.c:175
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_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:541
static struct value * ada_value_assign(struct value *toval, struct value *fromval)
Definition: ada-lang.c:2632
static const char * ada_decoded_op_name(enum exp_opcode)
Definition: ada-lang.c:3097
static void check_status_exception(enum ada_exception_catchpoint_kind ex, bpstat bs)
Definition: ada-lang.c:12181
void set_value_component_location(struct value *component, const struct value *whole)
Definition: value.c:1761
#define SYMBOL_IS_ARGUMENT(symbol)
Definition: symtab.h:795
static void show_ada_command(char *args, int from_tty)
Definition: ada-lang.c:13835
const char * bpdisp_text(enum bpdisp disp)
Definition: breakpoint.c:383
int user_select_syms(struct ada_symbol_info *syms, int nsyms, int max_results)
Definition: ada-lang.c:3736
__extension__ enum domain_enum_tag domain
Definition: symtab.h:730
static struct value * ada_read_var_value(struct symbol *var, struct frame_info *frame)
Definition: ada-lang.c:13751
static int fat_pntr_bounds_bitpos(struct type *)
Definition: ada-lang.c:1715
int get_selections(int *choices, int n_choices, int max_results, int is_all_choice, char *annotation_suffix)
Definition: ada-lang.c:3856
struct type * builtin_int
Definition: gdbtypes.h:1483
static struct ada_symbol_info * defns_collected(struct obstack *, int)
Definition: ada-lang.c:4746
static int compare_names(const char *string1, const char *string2)
Definition: ada-lang.c:5400
const ULONGEST const LONGEST len
Definition: target.h:309
static int ada_resolve_function(struct ada_symbol_info *, int, struct value **, int, const char *, struct type *)