]> git.ipfire.org Git - thirdparty/binutils-gdb.git/blame - gdb/ada-lang.c
2004-06-28 Michael Chastain <mec.gnu@mindspring.com>
[thirdparty/binutils-gdb.git] / gdb / ada-lang.c
CommitLineData
14f9c5c9 1/* Ada language support routines for GDB, the GNU debugger. Copyright
4c4b4cd2 2 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003, 2004.
de5ad195 3 Free Software Foundation, Inc.
14f9c5c9
AS
4
5This file is part of GDB.
6
7This program is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2 of the License, or
10(at your option) any later version.
11
12This program is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with this program; if not, write to the Free Software
19Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
20
96d887e8
PH
21
22/* Sections of code marked
23
24 #ifdef GNAT_GDB
25 ...
26 #endif
27
28 indicate sections that are used in sources distributed by
29 ACT, Inc., but not yet integrated into the public tree (where
30 GNAT_GDB is not defined). They are retained here nevertheless
31 to minimize the problems of maintaining different versions
32 of the source and to make the full source available. */
33
4c4b4cd2 34#include "defs.h"
14f9c5c9 35#include <stdio.h>
0c30c098 36#include "gdb_string.h"
14f9c5c9
AS
37#include <ctype.h>
38#include <stdarg.h>
39#include "demangle.h"
4c4b4cd2
PH
40#include "gdb_regex.h"
41#include "frame.h"
14f9c5c9
AS
42#include "symtab.h"
43#include "gdbtypes.h"
44#include "gdbcmd.h"
45#include "expression.h"
46#include "parser-defs.h"
47#include "language.h"
48#include "c-lang.h"
49#include "inferior.h"
50#include "symfile.h"
51#include "objfiles.h"
52#include "breakpoint.h"
53#include "gdbcore.h"
4c4b4cd2
PH
54#include "hashtab.h"
55#include "gdb_obstack.h"
14f9c5c9 56#include "ada-lang.h"
4c4b4cd2
PH
57#include "completer.h"
58#include "gdb_stat.h"
59#ifdef UI_OUT
14f9c5c9 60#include "ui-out.h"
4c4b4cd2 61#endif
fe898f56 62#include "block.h"
04714b91 63#include "infcall.h"
de4f826b 64#include "dictionary.h"
14f9c5c9 65
4c4b4cd2
PH
66#ifndef ADA_RETAIN_DOTS
67#define ADA_RETAIN_DOTS 0
68#endif
69
70/* Define whether or not the C operator '/' truncates towards zero for
71 differently signed operands (truncation direction is undefined in C).
72 Copied from valarith.c. */
73
74#ifndef TRUNCATION_TOWARDS_ZERO
75#define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
76#endif
77
96d887e8 78#ifdef GNAT_GDB
4c4b4cd2
PH
79/* A structure that contains a vector of strings.
80 The main purpose of this type is to group the vector and its
81 associated parameters in one structure. This makes it easier
82 to handle and pass around. */
14f9c5c9 83
4c4b4cd2
PH
84struct string_vector
85{
76a01679
JB
86 char **array; /* The vector itself. */
87 int index; /* Index of the next available element in the array. */
88 size_t size; /* The number of entries allocated in the array. */
4c4b4cd2
PH
89};
90
91static struct string_vector xnew_string_vector (int initial_size);
92static void string_vector_append (struct string_vector *sv, char *str);
96d887e8 93#endif /* GNAT_GDB */
4c4b4cd2
PH
94
95static const char *ada_unqualified_name (const char *decoded_name);
96static char *add_angle_brackets (const char *str);
97static void extract_string (CORE_ADDR addr, char *buf);
98static char *function_name_from_pc (CORE_ADDR pc);
14f9c5c9 99
d2e4a39e 100static struct type *ada_create_fundamental_type (struct objfile *, int);
14f9c5c9
AS
101
102static void modify_general_field (char *, LONGEST, int, int);
103
d2e4a39e 104static struct type *desc_base_type (struct type *);
14f9c5c9 105
d2e4a39e 106static struct type *desc_bounds_type (struct type *);
14f9c5c9 107
d2e4a39e 108static struct value *desc_bounds (struct value *);
14f9c5c9 109
d2e4a39e 110static int fat_pntr_bounds_bitpos (struct type *);
14f9c5c9 111
d2e4a39e 112static int fat_pntr_bounds_bitsize (struct type *);
14f9c5c9 113
d2e4a39e 114static struct type *desc_data_type (struct type *);
14f9c5c9 115
d2e4a39e 116static struct value *desc_data (struct value *);
14f9c5c9 117
d2e4a39e 118static int fat_pntr_data_bitpos (struct type *);
14f9c5c9 119
d2e4a39e 120static int fat_pntr_data_bitsize (struct type *);
14f9c5c9 121
d2e4a39e 122static struct value *desc_one_bound (struct value *, int, int);
14f9c5c9 123
d2e4a39e 124static int desc_bound_bitpos (struct type *, int, int);
14f9c5c9 125
d2e4a39e 126static int desc_bound_bitsize (struct type *, int, int);
14f9c5c9 127
d2e4a39e 128static struct type *desc_index_type (struct type *, int);
14f9c5c9 129
d2e4a39e 130static int desc_arity (struct type *);
14f9c5c9 131
d2e4a39e 132static int ada_type_match (struct type *, struct type *, int);
14f9c5c9 133
d2e4a39e 134static int ada_args_match (struct symbol *, struct value **, int);
14f9c5c9 135
4c4b4cd2 136static struct value *ensure_lval (struct value *, CORE_ADDR *);
14f9c5c9 137
d2e4a39e 138static struct value *convert_actual (struct value *, struct type *,
4c4b4cd2 139 CORE_ADDR *);
14f9c5c9 140
d2e4a39e 141static struct value *make_array_descriptor (struct type *, struct value *,
4c4b4cd2 142 CORE_ADDR *);
14f9c5c9 143
4c4b4cd2 144static void ada_add_block_symbols (struct obstack *,
76a01679 145 struct block *, const char *,
4c4b4cd2 146 domain_enum, struct objfile *,
76a01679 147 struct symtab *, int);
14f9c5c9 148
4c4b4cd2 149static int is_nonfunction (struct ada_symbol_info *, int);
14f9c5c9 150
76a01679
JB
151static void add_defn_to_vec (struct obstack *, struct symbol *,
152 struct block *, struct symtab *);
14f9c5c9 153
4c4b4cd2
PH
154static int num_defns_collected (struct obstack *);
155
156static struct ada_symbol_info *defns_collected (struct obstack *, int);
14f9c5c9 157
d2e4a39e 158static struct partial_symbol *ada_lookup_partial_symbol (struct partial_symtab
76a01679
JB
159 *, const char *, int,
160 domain_enum, int);
14f9c5c9 161
d2e4a39e 162static struct symtab *symtab_for_sym (struct symbol *);
14f9c5c9 163
4c4b4cd2 164static struct value *resolve_subexp (struct expression **, int *, int,
76a01679 165 struct type *);
14f9c5c9 166
d2e4a39e 167static void replace_operator_with_call (struct expression **, int, int, int,
4c4b4cd2 168 struct symbol *, struct block *);
14f9c5c9 169
d2e4a39e 170static int possible_user_operator_p (enum exp_opcode, struct value **);
14f9c5c9 171
4c4b4cd2
PH
172static char *ada_op_name (enum exp_opcode);
173
174static const char *ada_decoded_op_name (enum exp_opcode);
14f9c5c9 175
d2e4a39e 176static int numeric_type_p (struct type *);
14f9c5c9 177
d2e4a39e 178static int integer_type_p (struct type *);
14f9c5c9 179
d2e4a39e 180static int scalar_type_p (struct type *);
14f9c5c9 181
d2e4a39e 182static int discrete_type_p (struct type *);
14f9c5c9 183
4c4b4cd2 184static struct type *ada_lookup_struct_elt_type (struct type *, char *,
76a01679 185 int, int, int *);
4c4b4cd2 186
d2e4a39e 187static char *extended_canonical_line_spec (struct symtab_and_line,
4c4b4cd2 188 const char *);
14f9c5c9 189
d2e4a39e 190static struct value *evaluate_subexp (struct type *, struct expression *,
4c4b4cd2 191 int *, enum noside);
14f9c5c9 192
d2e4a39e 193static struct value *evaluate_subexp_type (struct expression *, int *);
14f9c5c9 194
d2e4a39e 195static struct type *ada_create_fundamental_type (struct objfile *, int);
14f9c5c9 196
d2e4a39e 197static int is_dynamic_field (struct type *, int);
14f9c5c9 198
d2e4a39e 199static struct type *to_fixed_variant_branch_type (struct type *, char *,
4c4b4cd2
PH
200 CORE_ADDR, struct value *);
201
202static struct type *to_fixed_array_type (struct type *, struct value *, int);
14f9c5c9 203
d2e4a39e 204static struct type *to_fixed_range_type (char *, struct value *,
4c4b4cd2 205 struct objfile *);
14f9c5c9 206
d2e4a39e 207static struct type *to_static_fixed_type (struct type *);
14f9c5c9 208
d2e4a39e 209static struct value *unwrap_value (struct value *);
14f9c5c9 210
d2e4a39e 211static struct type *packed_array_type (struct type *, long *);
14f9c5c9 212
d2e4a39e 213static struct type *decode_packed_array_type (struct type *);
14f9c5c9 214
d2e4a39e 215static struct value *decode_packed_array (struct value *);
14f9c5c9 216
d2e4a39e 217static struct value *value_subscript_packed (struct value *, int,
4c4b4cd2 218 struct value **);
14f9c5c9 219
4c4b4cd2
PH
220static struct value *coerce_unspec_val_to_type (struct value *,
221 struct type *);
14f9c5c9 222
d2e4a39e 223static struct value *get_var_value (char *, char *);
14f9c5c9 224
d2e4a39e 225static int lesseq_defined_than (struct symbol *, struct symbol *);
14f9c5c9 226
d2e4a39e 227static int equiv_types (struct type *, struct type *);
14f9c5c9 228
d2e4a39e 229static int is_name_suffix (const char *);
14f9c5c9 230
d2e4a39e 231static int wild_match (const char *, int, const char *);
14f9c5c9 232
76a01679 233static struct symtabs_and_lines
4c4b4cd2 234find_sal_from_funcs_and_line (const char *, int,
76a01679 235 struct ada_symbol_info *, int);
14f9c5c9 236
76a01679
JB
237static int find_line_in_linetable (struct linetable *, int,
238 struct ada_symbol_info *, int, int *);
14f9c5c9 239
d2e4a39e 240static int find_next_line_in_linetable (struct linetable *, int, int, int);
14f9c5c9 241
d2e4a39e 242static void read_all_symtabs (const char *);
14f9c5c9 243
d2e4a39e 244static int is_plausible_func_for_line (struct symbol *, int);
14f9c5c9 245
d2e4a39e 246static struct value *ada_coerce_ref (struct value *);
14f9c5c9 247
4c4b4cd2
PH
248static LONGEST pos_atr (struct value *);
249
d2e4a39e 250static struct value *value_pos_atr (struct value *);
14f9c5c9 251
d2e4a39e 252static struct value *value_val_atr (struct type *, struct value *);
14f9c5c9 253
4c4b4cd2
PH
254static struct symbol *standard_lookup (const char *, const struct block *,
255 domain_enum);
14f9c5c9 256
4c4b4cd2
PH
257static struct value *ada_search_struct_field (char *, struct value *, int,
258 struct type *);
259
260static struct value *ada_value_primitive_field (struct value *, int, int,
261 struct type *);
262
76a01679
JB
263static int find_struct_field (char *, struct type *, int,
264 struct type **, int *, int *, int *);
4c4b4cd2
PH
265
266static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR,
267 struct value *);
268
269static struct value *ada_to_fixed_value (struct value *);
14f9c5c9 270
4c4b4cd2 271static void adjust_pc_past_prologue (CORE_ADDR *);
d2e4a39e 272
4c4b4cd2
PH
273static int ada_resolve_function (struct ada_symbol_info *, int,
274 struct value **, int, const char *,
275 struct type *);
276
277static struct value *ada_coerce_to_simple_array (struct value *);
278
279static int ada_is_direct_array_type (struct type *);
280
281static void error_breakpoint_runtime_sym_not_found (const char *err_desc);
282
76a01679 283static int is_runtime_sym_defined (const char *name, int allow_tramp);
4c4b4cd2
PH
284\f
285
76a01679 286
4c4b4cd2 287/* Maximum-sized dynamic type. */
14f9c5c9
AS
288static unsigned int varsize_limit;
289
4c4b4cd2
PH
290/* FIXME: brobecker/2003-09-17: No longer a const because it is
291 returned by a function that does not return a const char *. */
292static char *ada_completer_word_break_characters =
293#ifdef VMS
294 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
295#else
14f9c5c9 296 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
4c4b4cd2 297#endif
14f9c5c9 298
4c4b4cd2 299/* The name of the symbol to use to get the name of the main subprogram. */
76a01679 300static const char ADA_MAIN_PROGRAM_SYMBOL_NAME[]
4c4b4cd2 301 = "__gnat_ada_main_program_name";
14f9c5c9 302
4c4b4cd2
PH
303/* The name of the runtime function called when an exception is raised. */
304static const char raise_sym_name[] = "__gnat_raise_nodefer_with_msg";
14f9c5c9 305
4c4b4cd2
PH
306/* The name of the runtime function called when an unhandled exception
307 is raised. */
308static const char raise_unhandled_sym_name[] = "__gnat_unhandled_exception";
309
310/* The name of the runtime function called when an assert failure is
311 raised. */
312static const char raise_assert_sym_name[] =
313 "system__assertions__raise_assert_failure";
314
315/* When GDB stops on an unhandled exception, GDB will go up the stack until
316 if finds a frame corresponding to this function, in order to extract the
317 name of the exception that has been raised from one of the parameters. */
318static const char process_raise_exception_name[] =
319 "ada__exceptions__process_raise_exception";
320
321/* A string that reflects the longest exception expression rewrite,
322 aside from the exception name. */
323static const char longest_exception_template[] =
324 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
325
326/* Limit on the number of warnings to raise per expression evaluation. */
327static int warning_limit = 2;
328
329/* Number of warning messages issued; reset to 0 by cleanups after
330 expression evaluation. */
331static int warnings_issued = 0;
332
333static const char *known_runtime_file_name_patterns[] = {
334 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
335};
336
337static const char *known_auxiliary_function_name_patterns[] = {
338 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
339};
340
341/* Space for allocating results of ada_lookup_symbol_list. */
342static struct obstack symbol_list_obstack;
343
344 /* Utilities */
345
96d887e8
PH
346#ifdef GNAT_GDB
347
4c4b4cd2
PH
348/* Create a new empty string_vector struct with an initial size of
349 INITIAL_SIZE. */
350
351static struct string_vector
352xnew_string_vector (int initial_size)
353{
354 struct string_vector result;
76a01679 355
4c4b4cd2
PH
356 result.array = (char **) xmalloc ((initial_size + 1) * sizeof (char *));
357 result.index = 0;
358 result.size = initial_size;
359
360 return result;
361}
362
363/* Add STR at the end of the given string vector SV. If SV is already
364 full, its size is automatically increased (doubled). */
365
366static void
367string_vector_append (struct string_vector *sv, char *str)
368{
369 if (sv->index >= sv->size)
370 GROW_VECT (sv->array, sv->size, sv->size * 2);
371
372 sv->array[sv->index] = str;
373 sv->index++;
374}
375
376/* Given DECODED_NAME a string holding a symbol name in its
377 decoded form (ie using the Ada dotted notation), returns
378 its unqualified name. */
379
380static const char *
381ada_unqualified_name (const char *decoded_name)
382{
383 const char *result = strrchr (decoded_name, '.');
384
385 if (result != NULL)
76a01679 386 result++; /* Skip the dot... */
4c4b4cd2
PH
387 else
388 result = decoded_name;
76a01679 389
4c4b4cd2
PH
390 return result;
391}
392
393/* Return a string starting with '<', followed by STR, and '>'.
394 The result is good until the next call. */
395
396static char *
397add_angle_brackets (const char *str)
398{
399 static char *result = NULL;
400
401 xfree (result);
402 result = (char *) xmalloc ((strlen (str) + 3) * sizeof (char));
403
404 sprintf (result, "<%s>", str);
405 return result;
406}
407
96d887e8
PH
408#endif /* GNAT_GDB */
409
4c4b4cd2
PH
410static char *
411ada_get_gdb_completer_word_break_characters (void)
412{
413 return ada_completer_word_break_characters;
414}
415
416/* Read the string located at ADDR from the inferior and store the
417 result into BUF. */
418
419static void
14f9c5c9
AS
420extract_string (CORE_ADDR addr, char *buf)
421{
d2e4a39e 422 int char_index = 0;
14f9c5c9 423
4c4b4cd2
PH
424 /* Loop, reading one byte at a time, until we reach the '\000'
425 end-of-string marker. */
d2e4a39e
AS
426 do
427 {
428 target_read_memory (addr + char_index * sizeof (char),
4c4b4cd2 429 buf + char_index * sizeof (char), sizeof (char));
d2e4a39e
AS
430 char_index++;
431 }
432 while (buf[char_index - 1] != '\000');
14f9c5c9
AS
433}
434
4c4b4cd2
PH
435/* Return the name of the function owning the instruction located at PC.
436 Return NULL if no such function could be found. */
437
438static char *
439function_name_from_pc (CORE_ADDR pc)
440{
441 char *func_name;
442
443 if (!find_pc_partial_function (pc, &func_name, NULL, NULL))
444 return NULL;
445
446 return func_name;
447}
448
14f9c5c9
AS
449/* Assuming *OLD_VECT points to an array of *SIZE objects of size
450 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
4c4b4cd2 451 updating *OLD_VECT and *SIZE as necessary. */
14f9c5c9
AS
452
453void
d2e4a39e 454grow_vect (void **old_vect, size_t * size, size_t min_size, int element_size)
14f9c5c9 455{
d2e4a39e
AS
456 if (*size < min_size)
457 {
458 *size *= 2;
459 if (*size < min_size)
4c4b4cd2 460 *size = min_size;
d2e4a39e
AS
461 *old_vect = xrealloc (*old_vect, *size * element_size);
462 }
14f9c5c9
AS
463}
464
465/* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
4c4b4cd2 466 suffix of FIELD_NAME beginning "___". */
14f9c5c9
AS
467
468static int
ebf56fd3 469field_name_match (const char *field_name, const char *target)
14f9c5c9
AS
470{
471 int len = strlen (target);
d2e4a39e 472 return
4c4b4cd2
PH
473 (strncmp (field_name, target, len) == 0
474 && (field_name[len] == '\0'
475 || (strncmp (field_name + len, "___", 3) == 0
76a01679
JB
476 && strcmp (field_name + strlen (field_name) - 6,
477 "___XVN") != 0)));
14f9c5c9
AS
478}
479
480
4c4b4cd2
PH
481/* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
482 FIELD_NAME, and return its index. This function also handles fields
483 whose name have ___ suffixes because the compiler sometimes alters
484 their name by adding such a suffix to represent fields with certain
485 constraints. If the field could not be found, return a negative
486 number if MAYBE_MISSING is set. Otherwise raise an error. */
487
488int
489ada_get_field_index (const struct type *type, const char *field_name,
490 int maybe_missing)
491{
492 int fieldno;
493 for (fieldno = 0; fieldno < TYPE_NFIELDS (type); fieldno++)
494 if (field_name_match (TYPE_FIELD_NAME (type, fieldno), field_name))
495 return fieldno;
496
497 if (!maybe_missing)
498 error ("Unable to find field %s in struct %s. Aborting",
499 field_name, TYPE_NAME (type));
500
501 return -1;
502}
503
504/* The length of the prefix of NAME prior to any "___" suffix. */
14f9c5c9
AS
505
506int
d2e4a39e 507ada_name_prefix_len (const char *name)
14f9c5c9
AS
508{
509 if (name == NULL)
510 return 0;
d2e4a39e 511 else
14f9c5c9 512 {
d2e4a39e 513 const char *p = strstr (name, "___");
14f9c5c9 514 if (p == NULL)
4c4b4cd2 515 return strlen (name);
14f9c5c9 516 else
4c4b4cd2 517 return p - name;
14f9c5c9
AS
518 }
519}
520
4c4b4cd2
PH
521/* Return non-zero if SUFFIX is a suffix of STR.
522 Return zero if STR is null. */
523
14f9c5c9 524static int
d2e4a39e 525is_suffix (const char *str, const char *suffix)
14f9c5c9
AS
526{
527 int len1, len2;
528 if (str == NULL)
529 return 0;
530 len1 = strlen (str);
531 len2 = strlen (suffix);
4c4b4cd2 532 return (len1 >= len2 && strcmp (str + len1 - len2, suffix) == 0);
14f9c5c9
AS
533}
534
535/* Create a value of type TYPE whose contents come from VALADDR, if it
4c4b4cd2
PH
536 is non-null, and whose memory address (in the inferior) is
537 ADDRESS. */
538
d2e4a39e
AS
539struct value *
540value_from_contents_and_address (struct type *type, char *valaddr,
4c4b4cd2 541 CORE_ADDR address)
14f9c5c9 542{
d2e4a39e
AS
543 struct value *v = allocate_value (type);
544 if (valaddr == NULL)
14f9c5c9
AS
545 VALUE_LAZY (v) = 1;
546 else
547 memcpy (VALUE_CONTENTS_RAW (v), valaddr, TYPE_LENGTH (type));
548 VALUE_ADDRESS (v) = address;
549 if (address != 0)
550 VALUE_LVAL (v) = lval_memory;
551 return v;
552}
553
4c4b4cd2
PH
554/* The contents of value VAL, treated as a value of type TYPE. The
555 result is an lval in memory if VAL is. */
14f9c5c9 556
d2e4a39e 557static struct value *
4c4b4cd2 558coerce_unspec_val_to_type (struct value *val, struct type *type)
14f9c5c9
AS
559{
560 CHECK_TYPEDEF (type);
4c4b4cd2
PH
561 if (VALUE_TYPE (val) == type)
562 return val;
d2e4a39e 563 else
14f9c5c9 564 {
4c4b4cd2
PH
565 struct value *result;
566
567 /* Make sure that the object size is not unreasonable before
568 trying to allocate some memory for it. */
569 if (TYPE_LENGTH (type) > varsize_limit)
570 error ("object size is larger than varsize-limit");
571
572 result = allocate_value (type);
573 VALUE_LVAL (result) = VALUE_LVAL (val);
574 VALUE_BITSIZE (result) = VALUE_BITSIZE (val);
575 VALUE_BITPOS (result) = VALUE_BITPOS (val);
576 VALUE_ADDRESS (result) = VALUE_ADDRESS (val) + VALUE_OFFSET (val);
1265e4aa
JB
577 if (VALUE_LAZY (val)
578 || TYPE_LENGTH (type) > TYPE_LENGTH (VALUE_TYPE (val)))
4c4b4cd2 579 VALUE_LAZY (result) = 1;
d2e4a39e 580 else
4c4b4cd2
PH
581 memcpy (VALUE_CONTENTS_RAW (result), VALUE_CONTENTS (val),
582 TYPE_LENGTH (type));
14f9c5c9
AS
583 return result;
584 }
585}
586
d2e4a39e
AS
587static char *
588cond_offset_host (char *valaddr, long offset)
14f9c5c9
AS
589{
590 if (valaddr == NULL)
591 return NULL;
592 else
593 return valaddr + offset;
594}
595
596static CORE_ADDR
ebf56fd3 597cond_offset_target (CORE_ADDR address, long offset)
14f9c5c9
AS
598{
599 if (address == 0)
600 return 0;
d2e4a39e 601 else
14f9c5c9
AS
602 return address + offset;
603}
604
4c4b4cd2
PH
605/* Issue a warning (as for the definition of warning in utils.c, but
606 with exactly one argument rather than ...), unless the limit on the
607 number of warnings has passed during the evaluation of the current
608 expression. */
14f9c5c9 609static void
4c4b4cd2 610lim_warning (const char *format, long arg)
14f9c5c9 611{
4c4b4cd2
PH
612 warnings_issued += 1;
613 if (warnings_issued <= warning_limit)
614 warning (format, arg);
615}
616
617static const char *
618ada_translate_error_message (const char *string)
619{
620 if (strcmp (string, "Invalid cast.") == 0)
621 return "Invalid type conversion.";
622 else
623 return string;
624}
625
626static LONGEST
76a01679 627MAX_OF_SIZE (int size)
4c4b4cd2 628{
76a01679
JB
629 LONGEST top_bit = (LONGEST) 1 << (size * 8 - 2);
630 return top_bit | (top_bit - 1);
4c4b4cd2
PH
631}
632
633static LONGEST
634MIN_OF_SIZE (int size)
635{
76a01679 636 return -MAX_OF_SIZE (size) - 1;
4c4b4cd2
PH
637}
638
639static ULONGEST
640UMAX_OF_SIZE (int size)
641{
76a01679
JB
642 ULONGEST top_bit = (ULONGEST) 1 << (size * 8 - 1);
643 return top_bit | (top_bit - 1);
4c4b4cd2
PH
644}
645
646static ULONGEST
647UMIN_OF_SIZE (int size)
648{
649 return 0;
650}
651
652/* The largest value in the domain of TYPE, a discrete type, as an integer. */
653static struct value *
654discrete_type_high_bound (struct type *type)
655{
76a01679 656 switch (TYPE_CODE (type))
4c4b4cd2
PH
657 {
658 case TYPE_CODE_RANGE:
659 return value_from_longest (TYPE_TARGET_TYPE (type),
76a01679 660 TYPE_HIGH_BOUND (type));
4c4b4cd2 661 case TYPE_CODE_ENUM:
76a01679
JB
662 return
663 value_from_longest (type,
664 TYPE_FIELD_BITPOS (type,
665 TYPE_NFIELDS (type) - 1));
666 case TYPE_CODE_INT:
4c4b4cd2
PH
667 return value_from_longest (type, MAX_OF_TYPE (type));
668 default:
669 error ("Unexpected type in discrete_type_high_bound.");
670 }
671}
672
673/* The largest value in the domain of TYPE, a discrete type, as an integer. */
674static struct value *
675discrete_type_low_bound (struct type *type)
676{
76a01679 677 switch (TYPE_CODE (type))
4c4b4cd2
PH
678 {
679 case TYPE_CODE_RANGE:
680 return value_from_longest (TYPE_TARGET_TYPE (type),
76a01679 681 TYPE_LOW_BOUND (type));
4c4b4cd2 682 case TYPE_CODE_ENUM:
76a01679
JB
683 return value_from_longest (type, TYPE_FIELD_BITPOS (type, 0));
684 case TYPE_CODE_INT:
4c4b4cd2
PH
685 return value_from_longest (type, MIN_OF_TYPE (type));
686 default:
687 error ("Unexpected type in discrete_type_low_bound.");
688 }
689}
690
691/* The identity on non-range types. For range types, the underlying
76a01679 692 non-range scalar type. */
4c4b4cd2
PH
693
694static struct type *
695base_type (struct type *type)
696{
697 while (type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE)
698 {
76a01679
JB
699 if (type == TYPE_TARGET_TYPE (type) || TYPE_TARGET_TYPE (type) == NULL)
700 return type;
4c4b4cd2
PH
701 type = TYPE_TARGET_TYPE (type);
702 }
703 return type;
14f9c5c9 704}
4c4b4cd2 705\f
76a01679 706
4c4b4cd2 707 /* Language Selection */
14f9c5c9
AS
708
709/* If the main program is in Ada, return language_ada, otherwise return LANG
710 (the main program is in Ada iif the adainit symbol is found).
711
4c4b4cd2 712 MAIN_PST is not used. */
d2e4a39e 713
14f9c5c9 714enum language
d2e4a39e 715ada_update_initial_language (enum language lang,
4c4b4cd2 716 struct partial_symtab *main_pst)
14f9c5c9 717{
d2e4a39e 718 if (lookup_minimal_symbol ("adainit", (const char *) NULL,
4c4b4cd2
PH
719 (struct objfile *) NULL) != NULL)
720 return language_ada;
14f9c5c9
AS
721
722 return lang;
723}
96d887e8
PH
724
725/* If the main procedure is written in Ada, then return its name.
726 The result is good until the next call. Return NULL if the main
727 procedure doesn't appear to be in Ada. */
728
729char *
730ada_main_name (void)
731{
732 struct minimal_symbol *msym;
733 CORE_ADDR main_program_name_addr;
734 static char main_program_name[1024];
735 /* For Ada, the name of the main procedure is stored in a specific
736 string constant, generated by the binder. Look for that symbol,
737 extract its address, and then read that string. If we didn't find
738 that string, then most probably the main procedure is not written
739 in Ada. */
740 msym = lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME, NULL, NULL);
741
742 if (msym != NULL)
743 {
744 main_program_name_addr = SYMBOL_VALUE_ADDRESS (msym);
745 if (main_program_name_addr == 0)
746 error ("Invalid address for Ada main program name.");
747
748 extract_string (main_program_name_addr, main_program_name);
749 return main_program_name;
750 }
751
752 /* The main procedure doesn't seem to be in Ada. */
753 return NULL;
754}
14f9c5c9 755\f
4c4b4cd2 756 /* Symbols */
d2e4a39e 757
4c4b4cd2
PH
758/* Table of Ada operators and their GNAT-encoded names. Last entry is pair
759 of NULLs. */
14f9c5c9 760
d2e4a39e
AS
761const struct ada_opname_map ada_opname_table[] = {
762 {"Oadd", "\"+\"", BINOP_ADD},
763 {"Osubtract", "\"-\"", BINOP_SUB},
764 {"Omultiply", "\"*\"", BINOP_MUL},
765 {"Odivide", "\"/\"", BINOP_DIV},
766 {"Omod", "\"mod\"", BINOP_MOD},
767 {"Orem", "\"rem\"", BINOP_REM},
768 {"Oexpon", "\"**\"", BINOP_EXP},
769 {"Olt", "\"<\"", BINOP_LESS},
770 {"Ole", "\"<=\"", BINOP_LEQ},
771 {"Ogt", "\">\"", BINOP_GTR},
772 {"Oge", "\">=\"", BINOP_GEQ},
773 {"Oeq", "\"=\"", BINOP_EQUAL},
774 {"One", "\"/=\"", BINOP_NOTEQUAL},
775 {"Oand", "\"and\"", BINOP_BITWISE_AND},
776 {"Oor", "\"or\"", BINOP_BITWISE_IOR},
777 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR},
778 {"Oconcat", "\"&\"", BINOP_CONCAT},
779 {"Oabs", "\"abs\"", UNOP_ABS},
780 {"Onot", "\"not\"", UNOP_LOGICAL_NOT},
781 {"Oadd", "\"+\"", UNOP_PLUS},
782 {"Osubtract", "\"-\"", UNOP_NEG},
783 {NULL, NULL}
14f9c5c9
AS
784};
785
4c4b4cd2
PH
786/* Return non-zero if STR should be suppressed in info listings. */
787
14f9c5c9 788static int
d2e4a39e 789is_suppressed_name (const char *str)
14f9c5c9 790{
4c4b4cd2 791 if (strncmp (str, "_ada_", 5) == 0)
14f9c5c9
AS
792 str += 5;
793 if (str[0] == '_' || str[0] == '\000')
794 return 1;
795 else
796 {
d2e4a39e
AS
797 const char *p;
798 const char *suffix = strstr (str, "___");
14f9c5c9 799 if (suffix != NULL && suffix[3] != 'X')
4c4b4cd2 800 return 1;
14f9c5c9 801 if (suffix == NULL)
4c4b4cd2 802 suffix = str + strlen (str);
d2e4a39e 803 for (p = suffix - 1; p != str; p -= 1)
4c4b4cd2
PH
804 if (isupper (*p))
805 {
806 int i;
807 if (p[0] == 'X' && p[-1] != '_')
808 goto OK;
809 if (*p != 'O')
810 return 1;
811 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
812 if (strncmp (ada_opname_table[i].encoded, p,
813 strlen (ada_opname_table[i].encoded)) == 0)
814 goto OK;
815 return 1;
816 OK:;
817 }
14f9c5c9
AS
818 return 0;
819 }
820}
821
4c4b4cd2
PH
822/* The "encoded" form of DECODED, according to GNAT conventions.
823 The result is valid until the next call to ada_encode. */
824
14f9c5c9 825char *
4c4b4cd2 826ada_encode (const char *decoded)
14f9c5c9 827{
4c4b4cd2
PH
828 static char *encoding_buffer = NULL;
829 static size_t encoding_buffer_size = 0;
d2e4a39e 830 const char *p;
14f9c5c9 831 int k;
d2e4a39e 832
4c4b4cd2 833 if (decoded == NULL)
14f9c5c9
AS
834 return NULL;
835
4c4b4cd2
PH
836 GROW_VECT (encoding_buffer, encoding_buffer_size,
837 2 * strlen (decoded) + 10);
14f9c5c9
AS
838
839 k = 0;
4c4b4cd2 840 for (p = decoded; *p != '\0'; p += 1)
14f9c5c9 841 {
4c4b4cd2
PH
842 if (!ADA_RETAIN_DOTS && *p == '.')
843 {
844 encoding_buffer[k] = encoding_buffer[k + 1] = '_';
845 k += 2;
846 }
14f9c5c9 847 else if (*p == '"')
4c4b4cd2
PH
848 {
849 const struct ada_opname_map *mapping;
850
851 for (mapping = ada_opname_table;
1265e4aa
JB
852 mapping->encoded != NULL
853 && strncmp (mapping->decoded, p,
854 strlen (mapping->decoded)) != 0; mapping += 1)
4c4b4cd2
PH
855 ;
856 if (mapping->encoded == NULL)
857 error ("invalid Ada operator name: %s", p);
858 strcpy (encoding_buffer + k, mapping->encoded);
859 k += strlen (mapping->encoded);
860 break;
861 }
d2e4a39e 862 else
4c4b4cd2
PH
863 {
864 encoding_buffer[k] = *p;
865 k += 1;
866 }
14f9c5c9
AS
867 }
868
4c4b4cd2
PH
869 encoding_buffer[k] = '\0';
870 return encoding_buffer;
14f9c5c9
AS
871}
872
873/* Return NAME folded to lower case, or, if surrounded by single
4c4b4cd2
PH
874 quotes, unfolded, but with the quotes stripped away. Result good
875 to next call. */
876
d2e4a39e
AS
877char *
878ada_fold_name (const char *name)
14f9c5c9 879{
d2e4a39e 880 static char *fold_buffer = NULL;
14f9c5c9
AS
881 static size_t fold_buffer_size = 0;
882
883 int len = strlen (name);
d2e4a39e 884 GROW_VECT (fold_buffer, fold_buffer_size, len + 1);
14f9c5c9
AS
885
886 if (name[0] == '\'')
887 {
d2e4a39e
AS
888 strncpy (fold_buffer, name + 1, len - 2);
889 fold_buffer[len - 2] = '\000';
14f9c5c9
AS
890 }
891 else
892 {
893 int i;
894 for (i = 0; i <= len; i += 1)
4c4b4cd2 895 fold_buffer[i] = tolower (name[i]);
14f9c5c9
AS
896 }
897
898 return fold_buffer;
899}
900
4c4b4cd2
PH
901/* decode:
902 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
903 These are suffixes introduced by GNAT5 to nested subprogram
904 names, and do not serve any purpose for the debugger.
905 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
14f9c5c9
AS
906 2. Convert other instances of embedded "__" to `.'.
907 3. Discard leading _ada_.
908 4. Convert operator names to the appropriate quoted symbols.
4c4b4cd2 909 5. Remove everything after first ___ if it is followed by
14f9c5c9
AS
910 'X'.
911 6. Replace TK__ with __, and a trailing B or TKB with nothing.
912 7. Put symbols that should be suppressed in <...> brackets.
913 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
14f9c5c9 914
4c4b4cd2
PH
915 The resulting string is valid until the next call of ada_decode.
916 If the string is unchanged by demangling, the original string pointer
917 is returned. */
918
919const char *
920ada_decode (const char *encoded)
14f9c5c9
AS
921{
922 int i, j;
923 int len0;
d2e4a39e 924 const char *p;
4c4b4cd2 925 char *decoded;
14f9c5c9 926 int at_start_name;
4c4b4cd2
PH
927 static char *decoding_buffer = NULL;
928 static size_t decoding_buffer_size = 0;
d2e4a39e 929
4c4b4cd2
PH
930 if (strncmp (encoded, "_ada_", 5) == 0)
931 encoded += 5;
14f9c5c9 932
4c4b4cd2 933 if (encoded[0] == '_' || encoded[0] == '<')
14f9c5c9
AS
934 goto Suppress;
935
4c4b4cd2
PH
936 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
937 len0 = strlen (encoded);
938 if (len0 > 1 && isdigit (encoded[len0 - 1]))
939 {
940 i = len0 - 2;
941 while (i > 0 && isdigit (encoded[i]))
942 i--;
943 if (i >= 0 && encoded[i] == '.')
944 len0 = i;
945 else if (i >= 2 && strncmp (encoded + i - 2, "___", 3) == 0)
946 len0 = i - 2;
947 }
948
949 /* Remove the ___X.* suffix if present. Do not forget to verify that
950 the suffix is located before the current "end" of ENCODED. We want
951 to avoid re-matching parts of ENCODED that have previously been
952 marked as discarded (by decrementing LEN0). */
953 p = strstr (encoded, "___");
954 if (p != NULL && p - encoded < len0 - 3)
14f9c5c9
AS
955 {
956 if (p[3] == 'X')
4c4b4cd2 957 len0 = p - encoded;
14f9c5c9 958 else
4c4b4cd2 959 goto Suppress;
14f9c5c9 960 }
4c4b4cd2
PH
961
962 if (len0 > 3 && strncmp (encoded + len0 - 3, "TKB", 3) == 0)
14f9c5c9 963 len0 -= 3;
76a01679 964
4c4b4cd2 965 if (len0 > 1 && strncmp (encoded + len0 - 1, "B", 1) == 0)
14f9c5c9
AS
966 len0 -= 1;
967
4c4b4cd2
PH
968 /* Make decoded big enough for possible expansion by operator name. */
969 GROW_VECT (decoding_buffer, decoding_buffer_size, 2 * len0 + 1);
970 decoded = decoding_buffer;
14f9c5c9 971
4c4b4cd2 972 if (len0 > 1 && isdigit (encoded[len0 - 1]))
d2e4a39e 973 {
4c4b4cd2
PH
974 i = len0 - 2;
975 while ((i >= 0 && isdigit (encoded[i]))
976 || (i >= 1 && encoded[i] == '_' && isdigit (encoded[i - 1])))
977 i -= 1;
978 if (i > 1 && encoded[i] == '_' && encoded[i - 1] == '_')
979 len0 = i - 1;
980 else if (encoded[i] == '$')
981 len0 = i;
d2e4a39e 982 }
14f9c5c9 983
4c4b4cd2
PH
984 for (i = 0, j = 0; i < len0 && !isalpha (encoded[i]); i += 1, j += 1)
985 decoded[j] = encoded[i];
14f9c5c9
AS
986
987 at_start_name = 1;
988 while (i < len0)
989 {
4c4b4cd2
PH
990 if (at_start_name && encoded[i] == 'O')
991 {
992 int k;
993 for (k = 0; ada_opname_table[k].encoded != NULL; k += 1)
994 {
995 int op_len = strlen (ada_opname_table[k].encoded);
996 if (strncmp (ada_opname_table[k].encoded + 1, encoded + i + 1,
76a01679 997 op_len - 1) == 0 && !isalnum (encoded[i + op_len]))
4c4b4cd2
PH
998 {
999 strcpy (decoded + j, ada_opname_table[k].decoded);
1000 at_start_name = 0;
1001 i += op_len;
1002 j += strlen (ada_opname_table[k].decoded);
1003 break;
1004 }
1005 }
1006 if (ada_opname_table[k].encoded != NULL)
1007 continue;
1008 }
14f9c5c9
AS
1009 at_start_name = 0;
1010
4c4b4cd2
PH
1011 if (i < len0 - 4 && strncmp (encoded + i, "TK__", 4) == 0)
1012 i += 2;
1013 if (encoded[i] == 'X' && i != 0 && isalnum (encoded[i - 1]))
1014 {
1015 do
1016 i += 1;
1017 while (i < len0 && (encoded[i] == 'b' || encoded[i] == 'n'));
1018 if (i < len0)
1019 goto Suppress;
1020 }
1021 else if (!ADA_RETAIN_DOTS
1022 && i < len0 - 2 && encoded[i] == '_' && encoded[i + 1] == '_')
1023 {
1024 decoded[j] = '.';
1025 at_start_name = 1;
1026 i += 2;
1027 j += 1;
1028 }
14f9c5c9 1029 else
4c4b4cd2
PH
1030 {
1031 decoded[j] = encoded[i];
1032 i += 1;
1033 j += 1;
1034 }
14f9c5c9 1035 }
4c4b4cd2 1036 decoded[j] = '\000';
14f9c5c9 1037
4c4b4cd2
PH
1038 for (i = 0; decoded[i] != '\0'; i += 1)
1039 if (isupper (decoded[i]) || decoded[i] == ' ')
14f9c5c9
AS
1040 goto Suppress;
1041
4c4b4cd2
PH
1042 if (strcmp (decoded, encoded) == 0)
1043 return encoded;
1044 else
1045 return decoded;
14f9c5c9
AS
1046
1047Suppress:
4c4b4cd2
PH
1048 GROW_VECT (decoding_buffer, decoding_buffer_size, strlen (encoded) + 3);
1049 decoded = decoding_buffer;
1050 if (encoded[0] == '<')
1051 strcpy (decoded, encoded);
14f9c5c9 1052 else
4c4b4cd2
PH
1053 sprintf (decoded, "<%s>", encoded);
1054 return decoded;
1055
1056}
1057
1058/* Table for keeping permanent unique copies of decoded names. Once
1059 allocated, names in this table are never released. While this is a
1060 storage leak, it should not be significant unless there are massive
1061 changes in the set of decoded names in successive versions of a
1062 symbol table loaded during a single session. */
1063static struct htab *decoded_names_store;
1064
1065/* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1066 in the language-specific part of GSYMBOL, if it has not been
1067 previously computed. Tries to save the decoded name in the same
1068 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1069 in any case, the decoded symbol has a lifetime at least that of
1070 GSYMBOL).
1071 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1072 const, but nevertheless modified to a semantically equivalent form
1073 when a decoded name is cached in it.
76a01679 1074*/
4c4b4cd2 1075
76a01679
JB
1076char *
1077ada_decode_symbol (const struct general_symbol_info *gsymbol)
4c4b4cd2 1078{
76a01679 1079 char **resultp =
4c4b4cd2
PH
1080 (char **) &gsymbol->language_specific.cplus_specific.demangled_name;
1081 if (*resultp == NULL)
1082 {
1083 const char *decoded = ada_decode (gsymbol->name);
1084 if (gsymbol->bfd_section != NULL)
76a01679
JB
1085 {
1086 bfd *obfd = gsymbol->bfd_section->owner;
1087 if (obfd != NULL)
1088 {
1089 struct objfile *objf;
1090 ALL_OBJFILES (objf)
1091 {
1092 if (obfd == objf->obfd)
1093 {
1094 *resultp = obsavestring (decoded, strlen (decoded),
1095 &objf->objfile_obstack);
1096 break;
1097 }
1098 }
1099 }
1100 }
4c4b4cd2 1101 /* Sometimes, we can't find a corresponding objfile, in which
76a01679
JB
1102 case, we put the result on the heap. Since we only decode
1103 when needed, we hope this usually does not cause a
1104 significant memory leak (FIXME). */
4c4b4cd2 1105 if (*resultp == NULL)
76a01679
JB
1106 {
1107 char **slot = (char **) htab_find_slot (decoded_names_store,
1108 decoded, INSERT);
1109 if (*slot == NULL)
1110 *slot = xstrdup (decoded);
1111 *resultp = *slot;
1112 }
4c4b4cd2 1113 }
14f9c5c9 1114
4c4b4cd2
PH
1115 return *resultp;
1116}
76a01679
JB
1117
1118char *
1119ada_la_decode (const char *encoded, int options)
4c4b4cd2
PH
1120{
1121 return xstrdup (ada_decode (encoded));
14f9c5c9
AS
1122}
1123
1124/* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
4c4b4cd2
PH
1125 suffixes that encode debugging information or leading _ada_ on
1126 SYM_NAME (see is_name_suffix commentary for the debugging
1127 information that is ignored). If WILD, then NAME need only match a
1128 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1129 either argument is NULL. */
14f9c5c9
AS
1130
1131int
d2e4a39e 1132ada_match_name (const char *sym_name, const char *name, int wild)
14f9c5c9
AS
1133{
1134 if (sym_name == NULL || name == NULL)
1135 return 0;
1136 else if (wild)
1137 return wild_match (name, strlen (name), sym_name);
d2e4a39e
AS
1138 else
1139 {
1140 int len_name = strlen (name);
4c4b4cd2
PH
1141 return (strncmp (sym_name, name, len_name) == 0
1142 && is_name_suffix (sym_name + len_name))
1143 || (strncmp (sym_name, "_ada_", 5) == 0
1144 && strncmp (sym_name + 5, name, len_name) == 0
1145 && is_name_suffix (sym_name + len_name + 5));
d2e4a39e 1146 }
14f9c5c9
AS
1147}
1148
4c4b4cd2
PH
1149/* True (non-zero) iff, in Ada mode, the symbol SYM should be
1150 suppressed in info listings. */
14f9c5c9
AS
1151
1152int
ebf56fd3 1153ada_suppress_symbol_printing (struct symbol *sym)
14f9c5c9 1154{
176620f1 1155 if (SYMBOL_DOMAIN (sym) == STRUCT_DOMAIN)
14f9c5c9 1156 return 1;
d2e4a39e 1157 else
4c4b4cd2 1158 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym));
14f9c5c9 1159}
14f9c5c9 1160\f
d2e4a39e 1161
4c4b4cd2 1162 /* Arrays */
14f9c5c9 1163
4c4b4cd2 1164/* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
14f9c5c9 1165
d2e4a39e
AS
1166static char *bound_name[] = {
1167 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
14f9c5c9
AS
1168 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1169};
1170
1171/* Maximum number of array dimensions we are prepared to handle. */
1172
4c4b4cd2 1173#define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
14f9c5c9 1174
4c4b4cd2 1175/* Like modify_field, but allows bitpos > wordlength. */
14f9c5c9
AS
1176
1177static void
ebf56fd3 1178modify_general_field (char *addr, LONGEST fieldval, int bitpos, int bitsize)
14f9c5c9 1179{
4c4b4cd2 1180 modify_field (addr + bitpos / 8, fieldval, bitpos % 8, bitsize);
14f9c5c9
AS
1181}
1182
1183
4c4b4cd2
PH
1184/* The desc_* routines return primitive portions of array descriptors
1185 (fat pointers). */
14f9c5c9
AS
1186
1187/* The descriptor or array type, if any, indicated by TYPE; removes
4c4b4cd2
PH
1188 level of indirection, if needed. */
1189
d2e4a39e
AS
1190static struct type *
1191desc_base_type (struct type *type)
14f9c5c9
AS
1192{
1193 if (type == NULL)
1194 return NULL;
1195 CHECK_TYPEDEF (type);
1265e4aa
JB
1196 if (type != NULL
1197 && (TYPE_CODE (type) == TYPE_CODE_PTR
1198 || TYPE_CODE (type) == TYPE_CODE_REF))
14f9c5c9
AS
1199 return check_typedef (TYPE_TARGET_TYPE (type));
1200 else
1201 return type;
1202}
1203
4c4b4cd2
PH
1204/* True iff TYPE indicates a "thin" array pointer type. */
1205
14f9c5c9 1206static int
d2e4a39e 1207is_thin_pntr (struct type *type)
14f9c5c9 1208{
d2e4a39e 1209 return
14f9c5c9
AS
1210 is_suffix (ada_type_name (desc_base_type (type)), "___XUT")
1211 || is_suffix (ada_type_name (desc_base_type (type)), "___XUT___XVE");
1212}
1213
4c4b4cd2
PH
1214/* The descriptor type for thin pointer type TYPE. */
1215
d2e4a39e
AS
1216static struct type *
1217thin_descriptor_type (struct type *type)
14f9c5c9 1218{
d2e4a39e 1219 struct type *base_type = desc_base_type (type);
14f9c5c9
AS
1220 if (base_type == NULL)
1221 return NULL;
1222 if (is_suffix (ada_type_name (base_type), "___XVE"))
1223 return base_type;
d2e4a39e 1224 else
14f9c5c9 1225 {
d2e4a39e 1226 struct type *alt_type = ada_find_parallel_type (base_type, "___XVE");
14f9c5c9 1227 if (alt_type == NULL)
4c4b4cd2 1228 return base_type;
14f9c5c9 1229 else
4c4b4cd2 1230 return alt_type;
14f9c5c9
AS
1231 }
1232}
1233
4c4b4cd2
PH
1234/* A pointer to the array data for thin-pointer value VAL. */
1235
d2e4a39e
AS
1236static struct value *
1237thin_data_pntr (struct value *val)
14f9c5c9 1238{
d2e4a39e 1239 struct type *type = VALUE_TYPE (val);
14f9c5c9 1240 if (TYPE_CODE (type) == TYPE_CODE_PTR)
d2e4a39e 1241 return value_cast (desc_data_type (thin_descriptor_type (type)),
4c4b4cd2 1242 value_copy (val));
d2e4a39e 1243 else
14f9c5c9 1244 return value_from_longest (desc_data_type (thin_descriptor_type (type)),
4c4b4cd2 1245 VALUE_ADDRESS (val) + VALUE_OFFSET (val));
14f9c5c9
AS
1246}
1247
4c4b4cd2
PH
1248/* True iff TYPE indicates a "thick" array pointer type. */
1249
14f9c5c9 1250static int
d2e4a39e 1251is_thick_pntr (struct type *type)
14f9c5c9
AS
1252{
1253 type = desc_base_type (type);
1254 return (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2 1255 && lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL);
14f9c5c9
AS
1256}
1257
4c4b4cd2
PH
1258/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1259 pointer to one, the type of its bounds data; otherwise, NULL. */
76a01679 1260
d2e4a39e
AS
1261static struct type *
1262desc_bounds_type (struct type *type)
14f9c5c9 1263{
d2e4a39e 1264 struct type *r;
14f9c5c9
AS
1265
1266 type = desc_base_type (type);
1267
1268 if (type == NULL)
1269 return NULL;
1270 else if (is_thin_pntr (type))
1271 {
1272 type = thin_descriptor_type (type);
1273 if (type == NULL)
4c4b4cd2 1274 return NULL;
14f9c5c9
AS
1275 r = lookup_struct_elt_type (type, "BOUNDS", 1);
1276 if (r != NULL)
4c4b4cd2 1277 return check_typedef (r);
14f9c5c9
AS
1278 }
1279 else if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1280 {
1281 r = lookup_struct_elt_type (type, "P_BOUNDS", 1);
1282 if (r != NULL)
4c4b4cd2 1283 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r)));
14f9c5c9
AS
1284 }
1285 return NULL;
1286}
1287
1288/* If ARR is an array descriptor (fat or thin pointer), or pointer to
4c4b4cd2
PH
1289 one, a pointer to its bounds data. Otherwise NULL. */
1290
d2e4a39e
AS
1291static struct value *
1292desc_bounds (struct value *arr)
14f9c5c9 1293{
d2e4a39e
AS
1294 struct type *type = check_typedef (VALUE_TYPE (arr));
1295 if (is_thin_pntr (type))
14f9c5c9 1296 {
d2e4a39e 1297 struct type *bounds_type =
4c4b4cd2 1298 desc_bounds_type (thin_descriptor_type (type));
14f9c5c9
AS
1299 LONGEST addr;
1300
1301 if (desc_bounds_type == NULL)
4c4b4cd2 1302 error ("Bad GNAT array descriptor");
14f9c5c9
AS
1303
1304 /* NOTE: The following calculation is not really kosher, but
d2e4a39e 1305 since desc_type is an XVE-encoded type (and shouldn't be),
4c4b4cd2 1306 the correct calculation is a real pain. FIXME (and fix GCC). */
14f9c5c9 1307 if (TYPE_CODE (type) == TYPE_CODE_PTR)
4c4b4cd2 1308 addr = value_as_long (arr);
d2e4a39e 1309 else
4c4b4cd2 1310 addr = VALUE_ADDRESS (arr) + VALUE_OFFSET (arr);
14f9c5c9 1311
d2e4a39e 1312 return
4c4b4cd2
PH
1313 value_from_longest (lookup_pointer_type (bounds_type),
1314 addr - TYPE_LENGTH (bounds_type));
14f9c5c9
AS
1315 }
1316
1317 else if (is_thick_pntr (type))
d2e4a39e 1318 return value_struct_elt (&arr, NULL, "P_BOUNDS", NULL,
4c4b4cd2 1319 "Bad GNAT array descriptor");
14f9c5c9
AS
1320 else
1321 return NULL;
1322}
1323
4c4b4cd2
PH
1324/* If TYPE is the type of an array-descriptor (fat pointer), the bit
1325 position of the field containing the address of the bounds data. */
1326
14f9c5c9 1327static int
d2e4a39e 1328fat_pntr_bounds_bitpos (struct type *type)
14f9c5c9
AS
1329{
1330 return TYPE_FIELD_BITPOS (desc_base_type (type), 1);
1331}
1332
1333/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1334 size of the field containing the address of the bounds data. */
1335
14f9c5c9 1336static int
d2e4a39e 1337fat_pntr_bounds_bitsize (struct type *type)
14f9c5c9
AS
1338{
1339 type = desc_base_type (type);
1340
d2e4a39e 1341 if (TYPE_FIELD_BITSIZE (type, 1) > 0)
14f9c5c9
AS
1342 return TYPE_FIELD_BITSIZE (type, 1);
1343 else
1344 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type, 1)));
1345}
1346
4c4b4cd2 1347/* If TYPE is the type of an array descriptor (fat or thin pointer) or a
14f9c5c9 1348 pointer to one, the type of its array data (a
4c4b4cd2
PH
1349 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1350 ada_type_of_array to get an array type with bounds data. */
1351
d2e4a39e
AS
1352static struct type *
1353desc_data_type (struct type *type)
14f9c5c9
AS
1354{
1355 type = desc_base_type (type);
1356
4c4b4cd2 1357 /* NOTE: The following is bogus; see comment in desc_bounds. */
14f9c5c9 1358 if (is_thin_pntr (type))
d2e4a39e
AS
1359 return lookup_pointer_type
1360 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type), 1)));
14f9c5c9
AS
1361 else if (is_thick_pntr (type))
1362 return lookup_struct_elt_type (type, "P_ARRAY", 1);
1363 else
1364 return NULL;
1365}
1366
1367/* If ARR is an array descriptor (fat or thin pointer), a pointer to
1368 its array data. */
4c4b4cd2 1369
d2e4a39e
AS
1370static struct value *
1371desc_data (struct value *arr)
14f9c5c9 1372{
d2e4a39e 1373 struct type *type = VALUE_TYPE (arr);
14f9c5c9
AS
1374 if (is_thin_pntr (type))
1375 return thin_data_pntr (arr);
1376 else if (is_thick_pntr (type))
d2e4a39e 1377 return value_struct_elt (&arr, NULL, "P_ARRAY", NULL,
4c4b4cd2 1378 "Bad GNAT array descriptor");
14f9c5c9
AS
1379 else
1380 return NULL;
1381}
1382
1383
1384/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1385 position of the field containing the address of the data. */
1386
14f9c5c9 1387static int
d2e4a39e 1388fat_pntr_data_bitpos (struct type *type)
14f9c5c9
AS
1389{
1390 return TYPE_FIELD_BITPOS (desc_base_type (type), 0);
1391}
1392
1393/* If TYPE is the type of an array-descriptor (fat pointer), the bit
4c4b4cd2
PH
1394 size of the field containing the address of the data. */
1395
14f9c5c9 1396static int
d2e4a39e 1397fat_pntr_data_bitsize (struct type *type)
14f9c5c9
AS
1398{
1399 type = desc_base_type (type);
1400
1401 if (TYPE_FIELD_BITSIZE (type, 0) > 0)
1402 return TYPE_FIELD_BITSIZE (type, 0);
d2e4a39e 1403 else
14f9c5c9
AS
1404 return TARGET_CHAR_BIT * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
1405}
1406
4c4b4cd2 1407/* If BOUNDS is an array-bounds structure (or pointer to one), return
14f9c5c9 1408 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1409 bound, if WHICH is 1. The first bound is I=1. */
1410
d2e4a39e
AS
1411static struct value *
1412desc_one_bound (struct value *bounds, int i, int which)
14f9c5c9 1413{
d2e4a39e 1414 return value_struct_elt (&bounds, NULL, bound_name[2 * i + which - 2], NULL,
4c4b4cd2 1415 "Bad GNAT array descriptor bounds");
14f9c5c9
AS
1416}
1417
1418/* If BOUNDS is an array-bounds structure type, return the bit position
1419 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1420 bound, if WHICH is 1. The first bound is I=1. */
1421
14f9c5c9 1422static int
d2e4a39e 1423desc_bound_bitpos (struct type *type, int i, int which)
14f9c5c9 1424{
d2e4a39e 1425 return TYPE_FIELD_BITPOS (desc_base_type (type), 2 * i + which - 2);
14f9c5c9
AS
1426}
1427
1428/* If BOUNDS is an array-bounds structure type, return the bit field size
1429 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
4c4b4cd2
PH
1430 bound, if WHICH is 1. The first bound is I=1. */
1431
76a01679 1432static int
d2e4a39e 1433desc_bound_bitsize (struct type *type, int i, int which)
14f9c5c9
AS
1434{
1435 type = desc_base_type (type);
1436
d2e4a39e
AS
1437 if (TYPE_FIELD_BITSIZE (type, 2 * i + which - 2) > 0)
1438 return TYPE_FIELD_BITSIZE (type, 2 * i + which - 2);
1439 else
1440 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type, 2 * i + which - 2));
14f9c5c9
AS
1441}
1442
1443/* If TYPE is the type of an array-bounds structure, the type of its
4c4b4cd2
PH
1444 Ith bound (numbering from 1). Otherwise, NULL. */
1445
d2e4a39e
AS
1446static struct type *
1447desc_index_type (struct type *type, int i)
14f9c5c9
AS
1448{
1449 type = desc_base_type (type);
1450
1451 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
d2e4a39e
AS
1452 return lookup_struct_elt_type (type, bound_name[2 * i - 2], 1);
1453 else
14f9c5c9
AS
1454 return NULL;
1455}
1456
4c4b4cd2
PH
1457/* The number of index positions in the array-bounds type TYPE.
1458 Return 0 if TYPE is NULL. */
1459
14f9c5c9 1460static int
d2e4a39e 1461desc_arity (struct type *type)
14f9c5c9
AS
1462{
1463 type = desc_base_type (type);
1464
1465 if (type != NULL)
1466 return TYPE_NFIELDS (type) / 2;
1467 return 0;
1468}
1469
4c4b4cd2
PH
1470/* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1471 an array descriptor type (representing an unconstrained array
1472 type). */
1473
76a01679
JB
1474static int
1475ada_is_direct_array_type (struct type *type)
4c4b4cd2
PH
1476{
1477 if (type == NULL)
1478 return 0;
1479 CHECK_TYPEDEF (type);
1480 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
76a01679 1481 || ada_is_array_descriptor_type (type));
4c4b4cd2
PH
1482}
1483
1484/* Non-zero iff TYPE is a simple array type or pointer to one. */
14f9c5c9 1485
14f9c5c9 1486int
4c4b4cd2 1487ada_is_simple_array_type (struct type *type)
14f9c5c9
AS
1488{
1489 if (type == NULL)
1490 return 0;
1491 CHECK_TYPEDEF (type);
1492 return (TYPE_CODE (type) == TYPE_CODE_ARRAY
4c4b4cd2
PH
1493 || (TYPE_CODE (type) == TYPE_CODE_PTR
1494 && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY));
14f9c5c9
AS
1495}
1496
4c4b4cd2
PH
1497/* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1498
14f9c5c9 1499int
4c4b4cd2 1500ada_is_array_descriptor_type (struct type *type)
14f9c5c9 1501{
d2e4a39e 1502 struct type *data_type = desc_data_type (type);
14f9c5c9
AS
1503
1504 if (type == NULL)
1505 return 0;
1506 CHECK_TYPEDEF (type);
d2e4a39e 1507 return
14f9c5c9
AS
1508 data_type != NULL
1509 && ((TYPE_CODE (data_type) == TYPE_CODE_PTR
4c4b4cd2
PH
1510 && TYPE_TARGET_TYPE (data_type) != NULL
1511 && TYPE_CODE (TYPE_TARGET_TYPE (data_type)) == TYPE_CODE_ARRAY)
1265e4aa 1512 || TYPE_CODE (data_type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
1513 && desc_arity (desc_bounds_type (type)) > 0;
1514}
1515
1516/* Non-zero iff type is a partially mal-formed GNAT array
4c4b4cd2 1517 descriptor. FIXME: This is to compensate for some problems with
14f9c5c9 1518 debugging output from GNAT. Re-examine periodically to see if it
4c4b4cd2
PH
1519 is still needed. */
1520
14f9c5c9 1521int
ebf56fd3 1522ada_is_bogus_array_descriptor (struct type *type)
14f9c5c9 1523{
d2e4a39e 1524 return
14f9c5c9
AS
1525 type != NULL
1526 && TYPE_CODE (type) == TYPE_CODE_STRUCT
1527 && (lookup_struct_elt_type (type, "P_BOUNDS", 1) != NULL
4c4b4cd2
PH
1528 || lookup_struct_elt_type (type, "P_ARRAY", 1) != NULL)
1529 && !ada_is_array_descriptor_type (type);
14f9c5c9
AS
1530}
1531
1532
4c4b4cd2 1533/* If ARR has a record type in the form of a standard GNAT array descriptor,
14f9c5c9 1534 (fat pointer) returns the type of the array data described---specifically,
4c4b4cd2 1535 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
14f9c5c9 1536 in from the descriptor; otherwise, they are left unspecified. If
4c4b4cd2
PH
1537 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1538 returns NULL. The result is simply the type of ARR if ARR is not
14f9c5c9 1539 a descriptor. */
d2e4a39e
AS
1540struct type *
1541ada_type_of_array (struct value *arr, int bounds)
14f9c5c9
AS
1542{
1543 if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1544 return decode_packed_array_type (VALUE_TYPE (arr));
1545
4c4b4cd2 1546 if (!ada_is_array_descriptor_type (VALUE_TYPE (arr)))
14f9c5c9 1547 return VALUE_TYPE (arr);
d2e4a39e
AS
1548
1549 if (!bounds)
1550 return
1551 check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr))));
14f9c5c9
AS
1552 else
1553 {
d2e4a39e 1554 struct type *elt_type;
14f9c5c9 1555 int arity;
d2e4a39e 1556 struct value *descriptor;
14f9c5c9
AS
1557 struct objfile *objf = TYPE_OBJFILE (VALUE_TYPE (arr));
1558
1559 elt_type = ada_array_element_type (VALUE_TYPE (arr), -1);
1560 arity = ada_array_arity (VALUE_TYPE (arr));
1561
d2e4a39e 1562 if (elt_type == NULL || arity == 0)
4c4b4cd2 1563 return check_typedef (VALUE_TYPE (arr));
14f9c5c9
AS
1564
1565 descriptor = desc_bounds (arr);
d2e4a39e 1566 if (value_as_long (descriptor) == 0)
4c4b4cd2 1567 return NULL;
d2e4a39e 1568 while (arity > 0)
4c4b4cd2
PH
1569 {
1570 struct type *range_type = alloc_type (objf);
1571 struct type *array_type = alloc_type (objf);
1572 struct value *low = desc_one_bound (descriptor, arity, 0);
1573 struct value *high = desc_one_bound (descriptor, arity, 1);
1574 arity -= 1;
1575
1576 create_range_type (range_type, VALUE_TYPE (low),
1577 (int) value_as_long (low),
1578 (int) value_as_long (high));
1579 elt_type = create_array_type (array_type, elt_type, range_type);
1580 }
14f9c5c9
AS
1581
1582 return lookup_pointer_type (elt_type);
1583 }
1584}
1585
1586/* If ARR does not represent an array, returns ARR unchanged.
4c4b4cd2
PH
1587 Otherwise, returns either a standard GDB array with bounds set
1588 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1589 GDB array. Returns NULL if ARR is a null fat pointer. */
1590
d2e4a39e
AS
1591struct value *
1592ada_coerce_to_simple_array_ptr (struct value *arr)
14f9c5c9 1593{
4c4b4cd2 1594 if (ada_is_array_descriptor_type (VALUE_TYPE (arr)))
14f9c5c9 1595 {
d2e4a39e 1596 struct type *arrType = ada_type_of_array (arr, 1);
14f9c5c9 1597 if (arrType == NULL)
4c4b4cd2 1598 return NULL;
14f9c5c9
AS
1599 return value_cast (arrType, value_copy (desc_data (arr)));
1600 }
1601 else if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1602 return decode_packed_array (arr);
1603 else
1604 return arr;
1605}
1606
1607/* If ARR does not represent an array, returns ARR unchanged.
1608 Otherwise, returns a standard GDB array describing ARR (which may
4c4b4cd2
PH
1609 be ARR itself if it already is in the proper form). */
1610
1611static struct value *
d2e4a39e 1612ada_coerce_to_simple_array (struct value *arr)
14f9c5c9 1613{
4c4b4cd2 1614 if (ada_is_array_descriptor_type (VALUE_TYPE (arr)))
14f9c5c9 1615 {
d2e4a39e 1616 struct value *arrVal = ada_coerce_to_simple_array_ptr (arr);
14f9c5c9 1617 if (arrVal == NULL)
4c4b4cd2 1618 error ("Bounds unavailable for null array pointer.");
14f9c5c9
AS
1619 return value_ind (arrVal);
1620 }
1621 else if (ada_is_packed_array_type (VALUE_TYPE (arr)))
1622 return decode_packed_array (arr);
d2e4a39e 1623 else
14f9c5c9
AS
1624 return arr;
1625}
1626
1627/* If TYPE represents a GNAT array type, return it translated to an
1628 ordinary GDB array type (possibly with BITSIZE fields indicating
4c4b4cd2
PH
1629 packing). For other types, is the identity. */
1630
d2e4a39e
AS
1631struct type *
1632ada_coerce_to_simple_array_type (struct type *type)
14f9c5c9 1633{
d2e4a39e
AS
1634 struct value *mark = value_mark ();
1635 struct value *dummy = value_from_longest (builtin_type_long, 0);
1636 struct type *result;
14f9c5c9
AS
1637 VALUE_TYPE (dummy) = type;
1638 result = ada_type_of_array (dummy, 0);
4c4b4cd2 1639 value_free_to_mark (mark);
14f9c5c9
AS
1640 return result;
1641}
1642
4c4b4cd2
PH
1643/* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1644
14f9c5c9 1645int
d2e4a39e 1646ada_is_packed_array_type (struct type *type)
14f9c5c9
AS
1647{
1648 if (type == NULL)
1649 return 0;
4c4b4cd2 1650 type = desc_base_type (type);
14f9c5c9 1651 CHECK_TYPEDEF (type);
d2e4a39e 1652 return
14f9c5c9
AS
1653 ada_type_name (type) != NULL
1654 && strstr (ada_type_name (type), "___XP") != NULL;
1655}
1656
1657/* Given that TYPE is a standard GDB array type with all bounds filled
1658 in, and that the element size of its ultimate scalar constituents
1659 (that is, either its elements, or, if it is an array of arrays, its
1660 elements' elements, etc.) is *ELT_BITS, return an identical type,
1661 but with the bit sizes of its elements (and those of any
1662 constituent arrays) recorded in the BITSIZE components of its
4c4b4cd2
PH
1663 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1664 in bits. */
1665
d2e4a39e
AS
1666static struct type *
1667packed_array_type (struct type *type, long *elt_bits)
14f9c5c9 1668{
d2e4a39e
AS
1669 struct type *new_elt_type;
1670 struct type *new_type;
14f9c5c9
AS
1671 LONGEST low_bound, high_bound;
1672
1673 CHECK_TYPEDEF (type);
1674 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
1675 return type;
1676
1677 new_type = alloc_type (TYPE_OBJFILE (type));
1678 new_elt_type = packed_array_type (check_typedef (TYPE_TARGET_TYPE (type)),
4c4b4cd2 1679 elt_bits);
14f9c5c9
AS
1680 create_array_type (new_type, new_elt_type, TYPE_FIELD_TYPE (type, 0));
1681 TYPE_FIELD_BITSIZE (new_type, 0) = *elt_bits;
1682 TYPE_NAME (new_type) = ada_type_name (type);
1683
d2e4a39e 1684 if (get_discrete_bounds (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2 1685 &low_bound, &high_bound) < 0)
14f9c5c9
AS
1686 low_bound = high_bound = 0;
1687 if (high_bound < low_bound)
1688 *elt_bits = TYPE_LENGTH (new_type) = 0;
d2e4a39e 1689 else
14f9c5c9
AS
1690 {
1691 *elt_bits *= (high_bound - low_bound + 1);
d2e4a39e 1692 TYPE_LENGTH (new_type) =
4c4b4cd2 1693 (*elt_bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
14f9c5c9
AS
1694 }
1695
4c4b4cd2 1696 TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9
AS
1697 return new_type;
1698}
1699
4c4b4cd2
PH
1700/* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1701
d2e4a39e
AS
1702static struct type *
1703decode_packed_array_type (struct type *type)
1704{
4c4b4cd2 1705 struct symbol *sym;
d2e4a39e
AS
1706 struct block **blocks;
1707 const char *raw_name = ada_type_name (check_typedef (type));
1708 char *name = (char *) alloca (strlen (raw_name) + 1);
1709 char *tail = strstr (raw_name, "___XP");
1710 struct type *shadow_type;
14f9c5c9
AS
1711 long bits;
1712 int i, n;
1713
4c4b4cd2
PH
1714 type = desc_base_type (type);
1715
14f9c5c9
AS
1716 memcpy (name, raw_name, tail - raw_name);
1717 name[tail - raw_name] = '\000';
1718
4c4b4cd2
PH
1719 sym = standard_lookup (name, get_selected_block (0), VAR_DOMAIN);
1720 if (sym == NULL || SYMBOL_TYPE (sym) == NULL)
14f9c5c9 1721 {
4c4b4cd2 1722 lim_warning ("could not find bounds information on packed array", 0);
14f9c5c9
AS
1723 return NULL;
1724 }
4c4b4cd2 1725 shadow_type = SYMBOL_TYPE (sym);
14f9c5c9
AS
1726
1727 if (TYPE_CODE (shadow_type) != TYPE_CODE_ARRAY)
1728 {
4c4b4cd2
PH
1729 lim_warning ("could not understand bounds information on packed array",
1730 0);
14f9c5c9
AS
1731 return NULL;
1732 }
d2e4a39e 1733
14f9c5c9
AS
1734 if (sscanf (tail + sizeof ("___XP") - 1, "%ld", &bits) != 1)
1735 {
4c4b4cd2
PH
1736 lim_warning
1737 ("could not understand bit size information on packed array", 0);
14f9c5c9
AS
1738 return NULL;
1739 }
d2e4a39e 1740
14f9c5c9
AS
1741 return packed_array_type (shadow_type, &bits);
1742}
1743
4c4b4cd2 1744/* Given that ARR is a struct value *indicating a GNAT packed array,
14f9c5c9
AS
1745 returns a simple array that denotes that array. Its type is a
1746 standard GDB array type except that the BITSIZEs of the array
1747 target types are set to the number of bits in each element, and the
4c4b4cd2 1748 type length is set appropriately. */
14f9c5c9 1749
d2e4a39e
AS
1750static struct value *
1751decode_packed_array (struct value *arr)
14f9c5c9 1752{
4c4b4cd2 1753 struct type *type;
14f9c5c9 1754
4c4b4cd2
PH
1755 arr = ada_coerce_ref (arr);
1756 if (TYPE_CODE (VALUE_TYPE (arr)) == TYPE_CODE_PTR)
1757 arr = ada_value_ind (arr);
1758
1759 type = decode_packed_array_type (VALUE_TYPE (arr));
14f9c5c9
AS
1760 if (type == NULL)
1761 {
1762 error ("can't unpack array");
1763 return NULL;
1764 }
4c4b4cd2 1765 return coerce_unspec_val_to_type (arr, type);
14f9c5c9
AS
1766}
1767
1768
1769/* The value of the element of packed array ARR at the ARITY indices
4c4b4cd2 1770 given in IND. ARR must be a simple array. */
14f9c5c9 1771
d2e4a39e
AS
1772static struct value *
1773value_subscript_packed (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
1774{
1775 int i;
1776 int bits, elt_off, bit_off;
1777 long elt_total_bit_offset;
d2e4a39e
AS
1778 struct type *elt_type;
1779 struct value *v;
14f9c5c9
AS
1780
1781 bits = 0;
1782 elt_total_bit_offset = 0;
1783 elt_type = check_typedef (VALUE_TYPE (arr));
d2e4a39e 1784 for (i = 0; i < arity; i += 1)
14f9c5c9 1785 {
d2e4a39e 1786 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY
4c4b4cd2
PH
1787 || TYPE_FIELD_BITSIZE (elt_type, 0) == 0)
1788 error
1789 ("attempt to do packed indexing of something other than a packed array");
14f9c5c9 1790 else
4c4b4cd2
PH
1791 {
1792 struct type *range_type = TYPE_INDEX_TYPE (elt_type);
1793 LONGEST lowerbound, upperbound;
1794 LONGEST idx;
1795
1796 if (get_discrete_bounds (range_type, &lowerbound, &upperbound) < 0)
1797 {
1798 lim_warning ("don't know bounds of array", 0);
1799 lowerbound = upperbound = 0;
1800 }
1801
1802 idx = value_as_long (value_pos_atr (ind[i]));
1803 if (idx < lowerbound || idx > upperbound)
1804 lim_warning ("packed array index %ld out of bounds", (long) idx);
1805 bits = TYPE_FIELD_BITSIZE (elt_type, 0);
1806 elt_total_bit_offset += (idx - lowerbound) * bits;
1807 elt_type = check_typedef (TYPE_TARGET_TYPE (elt_type));
1808 }
14f9c5c9
AS
1809 }
1810 elt_off = elt_total_bit_offset / HOST_CHAR_BIT;
1811 bit_off = elt_total_bit_offset % HOST_CHAR_BIT;
d2e4a39e
AS
1812
1813 v = ada_value_primitive_packed_val (arr, NULL, elt_off, bit_off,
4c4b4cd2 1814 bits, elt_type);
14f9c5c9
AS
1815 if (VALUE_LVAL (arr) == lval_internalvar)
1816 VALUE_LVAL (v) = lval_internalvar_component;
1817 else
1818 VALUE_LVAL (v) = VALUE_LVAL (arr);
1819 return v;
1820}
1821
4c4b4cd2 1822/* Non-zero iff TYPE includes negative integer values. */
14f9c5c9
AS
1823
1824static int
d2e4a39e 1825has_negatives (struct type *type)
14f9c5c9 1826{
d2e4a39e
AS
1827 switch (TYPE_CODE (type))
1828 {
1829 default:
1830 return 0;
1831 case TYPE_CODE_INT:
1832 return !TYPE_UNSIGNED (type);
1833 case TYPE_CODE_RANGE:
1834 return TYPE_LOW_BOUND (type) < 0;
1835 }
14f9c5c9 1836}
d2e4a39e 1837
14f9c5c9
AS
1838
1839/* Create a new value of type TYPE from the contents of OBJ starting
1840 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1841 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
4c4b4cd2
PH
1842 assigning through the result will set the field fetched from.
1843 VALADDR is ignored unless OBJ is NULL, in which case,
1844 VALADDR+OFFSET must address the start of storage containing the
1845 packed value. The value returned in this case is never an lval.
1846 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
14f9c5c9 1847
d2e4a39e
AS
1848struct value *
1849ada_value_primitive_packed_val (struct value *obj, char *valaddr, long offset,
4c4b4cd2
PH
1850 int bit_offset, int bit_size,
1851 struct type *type)
14f9c5c9 1852{
d2e4a39e 1853 struct value *v;
4c4b4cd2
PH
1854 int src, /* Index into the source area */
1855 targ, /* Index into the target area */
1856 srcBitsLeft, /* Number of source bits left to move */
1857 nsrc, ntarg, /* Number of source and target bytes */
1858 unusedLS, /* Number of bits in next significant
1859 byte of source that are unused */
1860 accumSize; /* Number of meaningful bits in accum */
1861 unsigned char *bytes; /* First byte containing data to unpack */
d2e4a39e 1862 unsigned char *unpacked;
4c4b4cd2 1863 unsigned long accum; /* Staging area for bits being transferred */
14f9c5c9
AS
1864 unsigned char sign;
1865 int len = (bit_size + bit_offset + HOST_CHAR_BIT - 1) / 8;
4c4b4cd2
PH
1866 /* Transmit bytes from least to most significant; delta is the direction
1867 the indices move. */
14f9c5c9
AS
1868 int delta = BITS_BIG_ENDIAN ? -1 : 1;
1869
1870 CHECK_TYPEDEF (type);
1871
1872 if (obj == NULL)
1873 {
1874 v = allocate_value (type);
d2e4a39e 1875 bytes = (unsigned char *) (valaddr + offset);
14f9c5c9
AS
1876 }
1877 else if (VALUE_LAZY (obj))
1878 {
1879 v = value_at (type,
4c4b4cd2 1880 VALUE_ADDRESS (obj) + VALUE_OFFSET (obj) + offset, NULL);
d2e4a39e 1881 bytes = (unsigned char *) alloca (len);
14f9c5c9
AS
1882 read_memory (VALUE_ADDRESS (v), bytes, len);
1883 }
d2e4a39e 1884 else
14f9c5c9
AS
1885 {
1886 v = allocate_value (type);
d2e4a39e 1887 bytes = (unsigned char *) VALUE_CONTENTS (obj) + offset;
14f9c5c9 1888 }
d2e4a39e
AS
1889
1890 if (obj != NULL)
14f9c5c9
AS
1891 {
1892 VALUE_LVAL (v) = VALUE_LVAL (obj);
1893 if (VALUE_LVAL (obj) == lval_internalvar)
4c4b4cd2 1894 VALUE_LVAL (v) = lval_internalvar_component;
14f9c5c9
AS
1895 VALUE_ADDRESS (v) = VALUE_ADDRESS (obj) + VALUE_OFFSET (obj) + offset;
1896 VALUE_BITPOS (v) = bit_offset + VALUE_BITPOS (obj);
1897 VALUE_BITSIZE (v) = bit_size;
1898 if (VALUE_BITPOS (v) >= HOST_CHAR_BIT)
4c4b4cd2
PH
1899 {
1900 VALUE_ADDRESS (v) += 1;
1901 VALUE_BITPOS (v) -= HOST_CHAR_BIT;
1902 }
14f9c5c9
AS
1903 }
1904 else
1905 VALUE_BITSIZE (v) = bit_size;
d2e4a39e 1906 unpacked = (unsigned char *) VALUE_CONTENTS (v);
14f9c5c9
AS
1907
1908 srcBitsLeft = bit_size;
1909 nsrc = len;
1910 ntarg = TYPE_LENGTH (type);
1911 sign = 0;
1912 if (bit_size == 0)
1913 {
1914 memset (unpacked, 0, TYPE_LENGTH (type));
1915 return v;
1916 }
1917 else if (BITS_BIG_ENDIAN)
1918 {
d2e4a39e 1919 src = len - 1;
1265e4aa
JB
1920 if (has_negatives (type)
1921 && ((bytes[0] << bit_offset) & (1 << (HOST_CHAR_BIT - 1))))
4c4b4cd2 1922 sign = ~0;
d2e4a39e
AS
1923
1924 unusedLS =
4c4b4cd2
PH
1925 (HOST_CHAR_BIT - (bit_size + bit_offset) % HOST_CHAR_BIT)
1926 % HOST_CHAR_BIT;
14f9c5c9
AS
1927
1928 switch (TYPE_CODE (type))
4c4b4cd2
PH
1929 {
1930 case TYPE_CODE_ARRAY:
1931 case TYPE_CODE_UNION:
1932 case TYPE_CODE_STRUCT:
1933 /* Non-scalar values must be aligned at a byte boundary... */
1934 accumSize =
1935 (HOST_CHAR_BIT - bit_size % HOST_CHAR_BIT) % HOST_CHAR_BIT;
1936 /* ... And are placed at the beginning (most-significant) bytes
1937 of the target. */
1938 targ = src;
1939 break;
1940 default:
1941 accumSize = 0;
1942 targ = TYPE_LENGTH (type) - 1;
1943 break;
1944 }
14f9c5c9 1945 }
d2e4a39e 1946 else
14f9c5c9
AS
1947 {
1948 int sign_bit_offset = (bit_size + bit_offset - 1) % 8;
1949
1950 src = targ = 0;
1951 unusedLS = bit_offset;
1952 accumSize = 0;
1953
d2e4a39e 1954 if (has_negatives (type) && (bytes[len - 1] & (1 << sign_bit_offset)))
4c4b4cd2 1955 sign = ~0;
14f9c5c9 1956 }
d2e4a39e 1957
14f9c5c9
AS
1958 accum = 0;
1959 while (nsrc > 0)
1960 {
1961 /* Mask for removing bits of the next source byte that are not
4c4b4cd2 1962 part of the value. */
d2e4a39e 1963 unsigned int unusedMSMask =
4c4b4cd2
PH
1964 (1 << (srcBitsLeft >= HOST_CHAR_BIT ? HOST_CHAR_BIT : srcBitsLeft)) -
1965 1;
1966 /* Sign-extend bits for this byte. */
14f9c5c9 1967 unsigned int signMask = sign & ~unusedMSMask;
d2e4a39e 1968 accum |=
4c4b4cd2 1969 (((bytes[src] >> unusedLS) & unusedMSMask) | signMask) << accumSize;
14f9c5c9 1970 accumSize += HOST_CHAR_BIT - unusedLS;
d2e4a39e 1971 if (accumSize >= HOST_CHAR_BIT)
4c4b4cd2
PH
1972 {
1973 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
1974 accumSize -= HOST_CHAR_BIT;
1975 accum >>= HOST_CHAR_BIT;
1976 ntarg -= 1;
1977 targ += delta;
1978 }
14f9c5c9
AS
1979 srcBitsLeft -= HOST_CHAR_BIT - unusedLS;
1980 unusedLS = 0;
1981 nsrc -= 1;
1982 src += delta;
1983 }
1984 while (ntarg > 0)
1985 {
1986 accum |= sign << accumSize;
1987 unpacked[targ] = accum & ~(~0L << HOST_CHAR_BIT);
1988 accumSize -= HOST_CHAR_BIT;
1989 accum >>= HOST_CHAR_BIT;
1990 ntarg -= 1;
1991 targ += delta;
1992 }
1993
1994 return v;
1995}
d2e4a39e 1996
14f9c5c9
AS
1997/* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1998 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
4c4b4cd2 1999 not overlap. */
14f9c5c9 2000static void
d2e4a39e 2001move_bits (char *target, int targ_offset, char *source, int src_offset, int n)
14f9c5c9
AS
2002{
2003 unsigned int accum, mask;
2004 int accum_bits, chunk_size;
2005
2006 target += targ_offset / HOST_CHAR_BIT;
2007 targ_offset %= HOST_CHAR_BIT;
2008 source += src_offset / HOST_CHAR_BIT;
2009 src_offset %= HOST_CHAR_BIT;
d2e4a39e 2010 if (BITS_BIG_ENDIAN)
14f9c5c9
AS
2011 {
2012 accum = (unsigned char) *source;
2013 source += 1;
2014 accum_bits = HOST_CHAR_BIT - src_offset;
2015
d2e4a39e 2016 while (n > 0)
4c4b4cd2
PH
2017 {
2018 int unused_right;
2019 accum = (accum << HOST_CHAR_BIT) + (unsigned char) *source;
2020 accum_bits += HOST_CHAR_BIT;
2021 source += 1;
2022 chunk_size = HOST_CHAR_BIT - targ_offset;
2023 if (chunk_size > n)
2024 chunk_size = n;
2025 unused_right = HOST_CHAR_BIT - (chunk_size + targ_offset);
2026 mask = ((1 << chunk_size) - 1) << unused_right;
2027 *target =
2028 (*target & ~mask)
2029 | ((accum >> (accum_bits - chunk_size - unused_right)) & mask);
2030 n -= chunk_size;
2031 accum_bits -= chunk_size;
2032 target += 1;
2033 targ_offset = 0;
2034 }
14f9c5c9
AS
2035 }
2036 else
2037 {
2038 accum = (unsigned char) *source >> src_offset;
2039 source += 1;
2040 accum_bits = HOST_CHAR_BIT - src_offset;
2041
d2e4a39e 2042 while (n > 0)
4c4b4cd2
PH
2043 {
2044 accum = accum + ((unsigned char) *source << accum_bits);
2045 accum_bits += HOST_CHAR_BIT;
2046 source += 1;
2047 chunk_size = HOST_CHAR_BIT - targ_offset;
2048 if (chunk_size > n)
2049 chunk_size = n;
2050 mask = ((1 << chunk_size) - 1) << targ_offset;
2051 *target = (*target & ~mask) | ((accum << targ_offset) & mask);
2052 n -= chunk_size;
2053 accum_bits -= chunk_size;
2054 accum >>= chunk_size;
2055 target += 1;
2056 targ_offset = 0;
2057 }
14f9c5c9
AS
2058 }
2059}
2060
2061
2062/* Store the contents of FROMVAL into the location of TOVAL.
2063 Return a new value with the location of TOVAL and contents of
2064 FROMVAL. Handles assignment into packed fields that have
4c4b4cd2 2065 floating-point or non-scalar types. */
14f9c5c9 2066
d2e4a39e
AS
2067static struct value *
2068ada_value_assign (struct value *toval, struct value *fromval)
14f9c5c9 2069{
d2e4a39e 2070 struct type *type = VALUE_TYPE (toval);
14f9c5c9
AS
2071 int bits = VALUE_BITSIZE (toval);
2072
2073 if (!toval->modifiable)
2074 error ("Left operand of assignment is not a modifiable lvalue.");
2075
2076 COERCE_REF (toval);
2077
d2e4a39e 2078 if (VALUE_LVAL (toval) == lval_memory
14f9c5c9 2079 && bits > 0
d2e4a39e 2080 && (TYPE_CODE (type) == TYPE_CODE_FLT
4c4b4cd2 2081 || TYPE_CODE (type) == TYPE_CODE_STRUCT))
14f9c5c9 2082 {
d2e4a39e 2083 int len =
4c4b4cd2 2084 (VALUE_BITPOS (toval) + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT;
d2e4a39e
AS
2085 char *buffer = (char *) alloca (len);
2086 struct value *val;
14f9c5c9
AS
2087
2088 if (TYPE_CODE (type) == TYPE_CODE_FLT)
4c4b4cd2 2089 fromval = value_cast (type, fromval);
14f9c5c9
AS
2090
2091 read_memory (VALUE_ADDRESS (toval) + VALUE_OFFSET (toval), buffer, len);
2092 if (BITS_BIG_ENDIAN)
4c4b4cd2
PH
2093 move_bits (buffer, VALUE_BITPOS (toval),
2094 VALUE_CONTENTS (fromval),
2095 TYPE_LENGTH (VALUE_TYPE (fromval)) * TARGET_CHAR_BIT -
2096 bits, bits);
14f9c5c9 2097 else
4c4b4cd2
PH
2098 move_bits (buffer, VALUE_BITPOS (toval), VALUE_CONTENTS (fromval),
2099 0, bits);
d2e4a39e 2100 write_memory (VALUE_ADDRESS (toval) + VALUE_OFFSET (toval), buffer,
4c4b4cd2 2101 len);
14f9c5c9
AS
2102
2103 val = value_copy (toval);
2104 memcpy (VALUE_CONTENTS_RAW (val), VALUE_CONTENTS (fromval),
4c4b4cd2 2105 TYPE_LENGTH (type));
14f9c5c9 2106 VALUE_TYPE (val) = type;
d2e4a39e 2107
14f9c5c9
AS
2108 return val;
2109 }
2110
2111 return value_assign (toval, fromval);
2112}
2113
2114
4c4b4cd2
PH
2115/* The value of the element of array ARR at the ARITY indices given in IND.
2116 ARR may be either a simple array, GNAT array descriptor, or pointer
14f9c5c9
AS
2117 thereto. */
2118
d2e4a39e
AS
2119struct value *
2120ada_value_subscript (struct value *arr, int arity, struct value **ind)
14f9c5c9
AS
2121{
2122 int k;
d2e4a39e
AS
2123 struct value *elt;
2124 struct type *elt_type;
14f9c5c9
AS
2125
2126 elt = ada_coerce_to_simple_array (arr);
2127
2128 elt_type = check_typedef (VALUE_TYPE (elt));
d2e4a39e 2129 if (TYPE_CODE (elt_type) == TYPE_CODE_ARRAY
14f9c5c9
AS
2130 && TYPE_FIELD_BITSIZE (elt_type, 0) > 0)
2131 return value_subscript_packed (elt, arity, ind);
2132
2133 for (k = 0; k < arity; k += 1)
2134 {
2135 if (TYPE_CODE (elt_type) != TYPE_CODE_ARRAY)
4c4b4cd2 2136 error ("too many subscripts (%d expected)", k);
14f9c5c9
AS
2137 elt = value_subscript (elt, value_pos_atr (ind[k]));
2138 }
2139 return elt;
2140}
2141
2142/* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2143 value of the element of *ARR at the ARITY indices given in
4c4b4cd2 2144 IND. Does not read the entire array into memory. */
14f9c5c9 2145
d2e4a39e
AS
2146struct value *
2147ada_value_ptr_subscript (struct value *arr, struct type *type, int arity,
4c4b4cd2 2148 struct value **ind)
14f9c5c9
AS
2149{
2150 int k;
2151
2152 for (k = 0; k < arity; k += 1)
2153 {
2154 LONGEST lwb, upb;
d2e4a39e 2155 struct value *idx;
14f9c5c9
AS
2156
2157 if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
4c4b4cd2 2158 error ("too many subscripts (%d expected)", k);
d2e4a39e 2159 arr = value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
4c4b4cd2 2160 value_copy (arr));
14f9c5c9 2161 get_discrete_bounds (TYPE_INDEX_TYPE (type), &lwb, &upb);
4c4b4cd2
PH
2162 idx = value_pos_atr (ind[k]);
2163 if (lwb != 0)
2164 idx = value_sub (idx, value_from_longest (builtin_type_int, lwb));
14f9c5c9
AS
2165 arr = value_add (arr, idx);
2166 type = TYPE_TARGET_TYPE (type);
2167 }
2168
2169 return value_ind (arr);
2170}
2171
2172/* If type is a record type in the form of a standard GNAT array
2173 descriptor, returns the number of dimensions for type. If arr is a
2174 simple array, returns the number of "array of"s that prefix its
4c4b4cd2 2175 type designation. Otherwise, returns 0. */
14f9c5c9
AS
2176
2177int
d2e4a39e 2178ada_array_arity (struct type *type)
14f9c5c9
AS
2179{
2180 int arity;
2181
2182 if (type == NULL)
2183 return 0;
2184
2185 type = desc_base_type (type);
2186
2187 arity = 0;
d2e4a39e 2188 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9 2189 return desc_arity (desc_bounds_type (type));
d2e4a39e
AS
2190 else
2191 while (TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9 2192 {
4c4b4cd2
PH
2193 arity += 1;
2194 type = check_typedef (TYPE_TARGET_TYPE (type));
14f9c5c9 2195 }
d2e4a39e 2196
14f9c5c9
AS
2197 return arity;
2198}
2199
2200/* If TYPE is a record type in the form of a standard GNAT array
2201 descriptor or a simple array type, returns the element type for
2202 TYPE after indexing by NINDICES indices, or by all indices if
4c4b4cd2 2203 NINDICES is -1. Otherwise, returns NULL. */
14f9c5c9 2204
d2e4a39e
AS
2205struct type *
2206ada_array_element_type (struct type *type, int nindices)
14f9c5c9
AS
2207{
2208 type = desc_base_type (type);
2209
d2e4a39e 2210 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
14f9c5c9
AS
2211 {
2212 int k;
d2e4a39e 2213 struct type *p_array_type;
14f9c5c9
AS
2214
2215 p_array_type = desc_data_type (type);
2216
2217 k = ada_array_arity (type);
2218 if (k == 0)
4c4b4cd2 2219 return NULL;
d2e4a39e 2220
4c4b4cd2 2221 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
14f9c5c9 2222 if (nindices >= 0 && k > nindices)
4c4b4cd2 2223 k = nindices;
14f9c5c9 2224 p_array_type = TYPE_TARGET_TYPE (p_array_type);
d2e4a39e 2225 while (k > 0 && p_array_type != NULL)
4c4b4cd2
PH
2226 {
2227 p_array_type = check_typedef (TYPE_TARGET_TYPE (p_array_type));
2228 k -= 1;
2229 }
14f9c5c9
AS
2230 return p_array_type;
2231 }
2232 else if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
2233 {
2234 while (nindices != 0 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
4c4b4cd2
PH
2235 {
2236 type = TYPE_TARGET_TYPE (type);
2237 nindices -= 1;
2238 }
14f9c5c9
AS
2239 return type;
2240 }
2241
2242 return NULL;
2243}
2244
4c4b4cd2
PH
2245/* The type of nth index in arrays of given type (n numbering from 1).
2246 Does not examine memory. */
14f9c5c9 2247
d2e4a39e
AS
2248struct type *
2249ada_index_type (struct type *type, int n)
14f9c5c9 2250{
4c4b4cd2
PH
2251 struct type *result_type;
2252
14f9c5c9
AS
2253 type = desc_base_type (type);
2254
2255 if (n > ada_array_arity (type))
2256 return NULL;
2257
4c4b4cd2 2258 if (ada_is_simple_array_type (type))
14f9c5c9
AS
2259 {
2260 int i;
2261
2262 for (i = 1; i < n; i += 1)
4c4b4cd2
PH
2263 type = TYPE_TARGET_TYPE (type);
2264 result_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 0));
2265 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2266 has a target type of TYPE_CODE_UNDEF. We compensate here, but
76a01679
JB
2267 perhaps stabsread.c would make more sense. */
2268 if (result_type == NULL || TYPE_CODE (result_type) == TYPE_CODE_UNDEF)
2269 result_type = builtin_type_int;
14f9c5c9 2270
4c4b4cd2 2271 return result_type;
14f9c5c9 2272 }
d2e4a39e 2273 else
14f9c5c9
AS
2274 return desc_index_type (desc_bounds_type (type), n);
2275}
2276
2277/* Given that arr is an array type, returns the lower bound of the
2278 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
4c4b4cd2
PH
2279 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2280 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2281 bounds type. It works for other arrays with bounds supplied by
2282 run-time quantities other than discriminants. */
14f9c5c9
AS
2283
2284LONGEST
d2e4a39e 2285ada_array_bound_from_type (struct type * arr_type, int n, int which,
4c4b4cd2 2286 struct type ** typep)
14f9c5c9 2287{
d2e4a39e
AS
2288 struct type *type;
2289 struct type *index_type_desc;
14f9c5c9
AS
2290
2291 if (ada_is_packed_array_type (arr_type))
2292 arr_type = decode_packed_array_type (arr_type);
2293
4c4b4cd2 2294 if (arr_type == NULL || !ada_is_simple_array_type (arr_type))
14f9c5c9
AS
2295 {
2296 if (typep != NULL)
4c4b4cd2 2297 *typep = builtin_type_int;
d2e4a39e 2298 return (LONGEST) - which;
14f9c5c9
AS
2299 }
2300
2301 if (TYPE_CODE (arr_type) == TYPE_CODE_PTR)
2302 type = TYPE_TARGET_TYPE (arr_type);
2303 else
2304 type = arr_type;
2305
2306 index_type_desc = ada_find_parallel_type (type, "___XA");
d2e4a39e 2307 if (index_type_desc == NULL)
14f9c5c9 2308 {
d2e4a39e
AS
2309 struct type *range_type;
2310 struct type *index_type;
14f9c5c9 2311
d2e4a39e 2312 while (n > 1)
4c4b4cd2
PH
2313 {
2314 type = TYPE_TARGET_TYPE (type);
2315 n -= 1;
2316 }
14f9c5c9
AS
2317
2318 range_type = TYPE_INDEX_TYPE (type);
2319 index_type = TYPE_TARGET_TYPE (range_type);
2320 if (TYPE_CODE (index_type) == TYPE_CODE_UNDEF)
4c4b4cd2 2321 index_type = builtin_type_long;
14f9c5c9 2322 if (typep != NULL)
4c4b4cd2 2323 *typep = index_type;
d2e4a39e 2324 return
4c4b4cd2
PH
2325 (LONGEST) (which == 0
2326 ? TYPE_LOW_BOUND (range_type)
2327 : TYPE_HIGH_BOUND (range_type));
14f9c5c9 2328 }
d2e4a39e 2329 else
14f9c5c9 2330 {
d2e4a39e 2331 struct type *index_type =
4c4b4cd2
PH
2332 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, n - 1),
2333 NULL, TYPE_OBJFILE (arr_type));
14f9c5c9 2334 if (typep != NULL)
4c4b4cd2 2335 *typep = TYPE_TARGET_TYPE (index_type);
d2e4a39e 2336 return
4c4b4cd2
PH
2337 (LONGEST) (which == 0
2338 ? TYPE_LOW_BOUND (index_type)
2339 : TYPE_HIGH_BOUND (index_type));
14f9c5c9
AS
2340 }
2341}
2342
2343/* Given that arr is an array value, returns the lower bound of the
2344 nth index (numbering from 1) if which is 0, and the upper bound if
4c4b4cd2
PH
2345 which is 1. This routine will also work for arrays with bounds
2346 supplied by run-time quantities other than discriminants. */
14f9c5c9 2347
d2e4a39e 2348struct value *
4dc81987 2349ada_array_bound (struct value *arr, int n, int which)
14f9c5c9 2350{
d2e4a39e 2351 struct type *arr_type = VALUE_TYPE (arr);
14f9c5c9
AS
2352
2353 if (ada_is_packed_array_type (arr_type))
2354 return ada_array_bound (decode_packed_array (arr), n, which);
4c4b4cd2 2355 else if (ada_is_simple_array_type (arr_type))
14f9c5c9 2356 {
d2e4a39e 2357 struct type *type;
14f9c5c9
AS
2358 LONGEST v = ada_array_bound_from_type (arr_type, n, which, &type);
2359 return value_from_longest (type, v);
2360 }
2361 else
2362 return desc_one_bound (desc_bounds (arr), n, which);
2363}
2364
2365/* Given that arr is an array value, returns the length of the
2366 nth index. This routine will also work for arrays with bounds
4c4b4cd2
PH
2367 supplied by run-time quantities other than discriminants.
2368 Does not work for arrays indexed by enumeration types with representation
2369 clauses at the moment. */
14f9c5c9 2370
d2e4a39e
AS
2371struct value *
2372ada_array_length (struct value *arr, int n)
14f9c5c9 2373{
d2e4a39e 2374 struct type *arr_type = check_typedef (VALUE_TYPE (arr));
14f9c5c9
AS
2375
2376 if (ada_is_packed_array_type (arr_type))
2377 return ada_array_length (decode_packed_array (arr), n);
2378
4c4b4cd2 2379 if (ada_is_simple_array_type (arr_type))
14f9c5c9 2380 {
d2e4a39e 2381 struct type *type;
14f9c5c9 2382 LONGEST v =
4c4b4cd2
PH
2383 ada_array_bound_from_type (arr_type, n, 1, &type) -
2384 ada_array_bound_from_type (arr_type, n, 0, NULL) + 1;
14f9c5c9
AS
2385 return value_from_longest (type, v);
2386 }
2387 else
d2e4a39e 2388 return
14f9c5c9 2389 value_from_longest (builtin_type_ada_int,
4c4b4cd2
PH
2390 value_as_long (desc_one_bound (desc_bounds (arr),
2391 n, 1))
2392 - value_as_long (desc_one_bound (desc_bounds (arr),
2393 n, 0)) + 1);
2394}
2395
2396/* An empty array whose type is that of ARR_TYPE (an array type),
2397 with bounds LOW to LOW-1. */
2398
2399static struct value *
2400empty_array (struct type *arr_type, int low)
2401{
2402 return allocate_value (create_range_type (NULL, TYPE_INDEX_TYPE (arr_type),
2403 low, low - 1));
14f9c5c9 2404}
14f9c5c9 2405\f
d2e4a39e 2406
4c4b4cd2 2407 /* Name resolution */
14f9c5c9 2408
4c4b4cd2
PH
2409/* The "decoded" name for the user-definable Ada operator corresponding
2410 to OP. */
14f9c5c9 2411
d2e4a39e 2412static const char *
4c4b4cd2 2413ada_decoded_op_name (enum exp_opcode op)
14f9c5c9
AS
2414{
2415 int i;
2416
4c4b4cd2 2417 for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
14f9c5c9
AS
2418 {
2419 if (ada_opname_table[i].op == op)
4c4b4cd2 2420 return ada_opname_table[i].decoded;
14f9c5c9
AS
2421 }
2422 error ("Could not find operator name for opcode");
2423}
2424
2425
4c4b4cd2
PH
2426/* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2427 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2428 undefined namespace) and converts operators that are
2429 user-defined into appropriate function calls. If CONTEXT_TYPE is
14f9c5c9
AS
2430 non-null, it provides a preferred result type [at the moment, only
2431 type void has any effect---causing procedures to be preferred over
2432 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
4c4b4cd2 2433 return type is preferred. May change (expand) *EXP. */
14f9c5c9 2434
4c4b4cd2
PH
2435static void
2436resolve (struct expression **expp, int void_context_p)
14f9c5c9
AS
2437{
2438 int pc;
2439 pc = 0;
4c4b4cd2 2440 resolve_subexp (expp, &pc, 1, void_context_p ? builtin_type_void : NULL);
14f9c5c9
AS
2441}
2442
4c4b4cd2
PH
2443/* Resolve the operator of the subexpression beginning at
2444 position *POS of *EXPP. "Resolving" consists of replacing
2445 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2446 with their resolutions, replacing built-in operators with
2447 function calls to user-defined operators, where appropriate, and,
2448 when DEPROCEDURE_P is non-zero, converting function-valued variables
2449 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2450 are as in ada_resolve, above. */
14f9c5c9 2451
d2e4a39e 2452static struct value *
4c4b4cd2 2453resolve_subexp (struct expression **expp, int *pos, int deprocedure_p,
76a01679 2454 struct type *context_type)
14f9c5c9
AS
2455{
2456 int pc = *pos;
2457 int i;
4c4b4cd2 2458 struct expression *exp; /* Convenience: == *expp. */
14f9c5c9 2459 enum exp_opcode op = (*expp)->elts[pc].opcode;
4c4b4cd2
PH
2460 struct value **argvec; /* Vector of operand types (alloca'ed). */
2461 int nargs; /* Number of operands. */
14f9c5c9
AS
2462
2463 argvec = NULL;
2464 nargs = 0;
2465 exp = *expp;
2466
4c4b4cd2 2467 /* Pass one: resolve operands, saving their types and updating *pos. */
14f9c5c9
AS
2468 switch (op)
2469 {
4c4b4cd2
PH
2470 case OP_FUNCALL:
2471 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679
JB
2472 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
2473 *pos += 7;
4c4b4cd2
PH
2474 else
2475 {
2476 *pos += 3;
2477 resolve_subexp (expp, pos, 0, NULL);
2478 }
2479 nargs = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9
AS
2480 break;
2481
4c4b4cd2
PH
2482 case UNOP_QUAL:
2483 *pos += 3;
2484 resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
14f9c5c9
AS
2485 break;
2486
14f9c5c9 2487 case UNOP_ADDR:
4c4b4cd2
PH
2488 *pos += 1;
2489 resolve_subexp (expp, pos, 0, NULL);
2490 break;
2491
2492 case OP_ATR_MODULUS:
2493 *pos += 4;
2494 break;
2495
2496 case OP_ATR_SIZE:
2497 case OP_ATR_TAG:
2498 *pos += 1;
14f9c5c9 2499 nargs = 1;
4c4b4cd2
PH
2500 break;
2501
2502 case OP_ATR_FIRST:
2503 case OP_ATR_LAST:
2504 case OP_ATR_LENGTH:
2505 case OP_ATR_POS:
2506 case OP_ATR_VAL:
14f9c5c9 2507 *pos += 1;
4c4b4cd2
PH
2508 nargs = 2;
2509 break;
2510
2511 case OP_ATR_MIN:
2512 case OP_ATR_MAX:
2513 *pos += 1;
2514 nargs = 3;
14f9c5c9
AS
2515 break;
2516
2517 case BINOP_ASSIGN:
2518 {
4c4b4cd2
PH
2519 struct value *arg1;
2520
2521 *pos += 1;
2522 arg1 = resolve_subexp (expp, pos, 0, NULL);
2523 if (arg1 == NULL)
2524 resolve_subexp (expp, pos, 1, NULL);
2525 else
2526 resolve_subexp (expp, pos, 1, VALUE_TYPE (arg1));
2527 break;
14f9c5c9
AS
2528 }
2529
4c4b4cd2
PH
2530 case UNOP_CAST:
2531 case UNOP_IN_RANGE:
2532 *pos += 3;
2533 nargs = 1;
2534 break;
14f9c5c9 2535
4c4b4cd2
PH
2536 case BINOP_ADD:
2537 case BINOP_SUB:
2538 case BINOP_MUL:
2539 case BINOP_DIV:
2540 case BINOP_REM:
2541 case BINOP_MOD:
2542 case BINOP_EXP:
2543 case BINOP_CONCAT:
2544 case BINOP_LOGICAL_AND:
2545 case BINOP_LOGICAL_OR:
2546 case BINOP_BITWISE_AND:
2547 case BINOP_BITWISE_IOR:
2548 case BINOP_BITWISE_XOR:
14f9c5c9 2549
4c4b4cd2
PH
2550 case BINOP_EQUAL:
2551 case BINOP_NOTEQUAL:
2552 case BINOP_LESS:
2553 case BINOP_GTR:
2554 case BINOP_LEQ:
2555 case BINOP_GEQ:
14f9c5c9 2556
4c4b4cd2
PH
2557 case BINOP_REPEAT:
2558 case BINOP_SUBSCRIPT:
2559 case BINOP_COMMA:
2560 *pos += 1;
2561 nargs = 2;
2562 break;
14f9c5c9 2563
4c4b4cd2
PH
2564 case UNOP_NEG:
2565 case UNOP_PLUS:
2566 case UNOP_LOGICAL_NOT:
2567 case UNOP_ABS:
2568 case UNOP_IND:
2569 *pos += 1;
2570 nargs = 1;
2571 break;
14f9c5c9 2572
4c4b4cd2
PH
2573 case OP_LONG:
2574 case OP_DOUBLE:
2575 case OP_VAR_VALUE:
2576 *pos += 4;
2577 break;
14f9c5c9 2578
4c4b4cd2
PH
2579 case OP_TYPE:
2580 case OP_BOOL:
2581 case OP_LAST:
2582 case OP_REGISTER:
2583 case OP_INTERNALVAR:
2584 *pos += 3;
2585 break;
14f9c5c9 2586
4c4b4cd2
PH
2587 case UNOP_MEMVAL:
2588 *pos += 3;
2589 nargs = 1;
2590 break;
2591
2592 case STRUCTOP_STRUCT:
2593 *pos += 4 + BYTES_TO_EXP_ELEM (exp->elts[pc + 1].longconst + 1);
2594 nargs = 1;
2595 break;
2596
2597 case OP_STRING:
76a01679
JB
2598 (*pos) += 3
2599 + BYTES_TO_EXP_ELEM (longest_to_int (exp->elts[pc + 1].longconst) +
2600 1);
4c4b4cd2
PH
2601 break;
2602
2603 case TERNOP_SLICE:
2604 case TERNOP_IN_RANGE:
2605 *pos += 1;
2606 nargs = 3;
2607 break;
2608
2609 case BINOP_IN_BOUNDS:
2610 *pos += 3;
2611 nargs = 2;
14f9c5c9 2612 break;
4c4b4cd2
PH
2613
2614 default:
2615 error ("Unexpected operator during name resolution");
14f9c5c9
AS
2616 }
2617
76a01679 2618 argvec = (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
4c4b4cd2
PH
2619 for (i = 0; i < nargs; i += 1)
2620 argvec[i] = resolve_subexp (expp, pos, 1, NULL);
2621 argvec[i] = NULL;
2622 exp = *expp;
2623
2624 /* Pass two: perform any resolution on principal operator. */
14f9c5c9
AS
2625 switch (op)
2626 {
2627 default:
2628 break;
2629
14f9c5c9 2630 case OP_VAR_VALUE:
4c4b4cd2 2631 if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
2632 {
2633 struct ada_symbol_info *candidates;
2634 int n_candidates;
2635
2636 n_candidates =
2637 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2638 (exp->elts[pc + 2].symbol),
2639 exp->elts[pc + 1].block, VAR_DOMAIN,
2640 &candidates);
2641
2642 if (n_candidates > 1)
2643 {
2644 /* Types tend to get re-introduced locally, so if there
2645 are any local symbols that are not types, first filter
2646 out all types. */
2647 int j;
2648 for (j = 0; j < n_candidates; j += 1)
2649 switch (SYMBOL_CLASS (candidates[j].sym))
2650 {
2651 case LOC_REGISTER:
2652 case LOC_ARG:
2653 case LOC_REF_ARG:
2654 case LOC_REGPARM:
2655 case LOC_REGPARM_ADDR:
2656 case LOC_LOCAL:
2657 case LOC_LOCAL_ARG:
2658 case LOC_BASEREG:
2659 case LOC_BASEREG_ARG:
2660 case LOC_COMPUTED:
2661 case LOC_COMPUTED_ARG:
2662 goto FoundNonType;
2663 default:
2664 break;
2665 }
2666 FoundNonType:
2667 if (j < n_candidates)
2668 {
2669 j = 0;
2670 while (j < n_candidates)
2671 {
2672 if (SYMBOL_CLASS (candidates[j].sym) == LOC_TYPEDEF)
2673 {
2674 candidates[j] = candidates[n_candidates - 1];
2675 n_candidates -= 1;
2676 }
2677 else
2678 j += 1;
2679 }
2680 }
2681 }
2682
2683 if (n_candidates == 0)
2684 error ("No definition found for %s",
2685 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2686 else if (n_candidates == 1)
2687 i = 0;
2688 else if (deprocedure_p
2689 && !is_nonfunction (candidates, n_candidates))
2690 {
2691 i = ada_resolve_function (candidates, n_candidates, NULL, 0,
2692 SYMBOL_LINKAGE_NAME (exp->
2693 elts[pc +
2694 2].symbol),
2695 context_type);
2696 if (i < 0)
2697 error ("Could not find a match for %s",
2698 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2699 }
2700 else
2701 {
2702 printf_filtered ("Multiple matches for %s\n",
2703 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
2704 user_select_syms (candidates, n_candidates, 1);
2705 i = 0;
2706 }
2707
2708 exp->elts[pc + 1].block = candidates[i].block;
2709 exp->elts[pc + 2].symbol = candidates[i].sym;
1265e4aa
JB
2710 if (innermost_block == NULL
2711 || contained_in (candidates[i].block, innermost_block))
76a01679
JB
2712 innermost_block = candidates[i].block;
2713 }
2714
2715 if (deprocedure_p
2716 && (TYPE_CODE (SYMBOL_TYPE (exp->elts[pc + 2].symbol))
2717 == TYPE_CODE_FUNC))
2718 {
2719 replace_operator_with_call (expp, pc, 0, 0,
2720 exp->elts[pc + 2].symbol,
2721 exp->elts[pc + 1].block);
2722 exp = *expp;
2723 }
14f9c5c9
AS
2724 break;
2725
2726 case OP_FUNCALL:
2727 {
4c4b4cd2 2728 if (exp->elts[pc + 3].opcode == OP_VAR_VALUE
76a01679 2729 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2
PH
2730 {
2731 struct ada_symbol_info *candidates;
2732 int n_candidates;
2733
2734 n_candidates =
76a01679
JB
2735 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2736 (exp->elts[pc + 5].symbol),
2737 exp->elts[pc + 4].block, VAR_DOMAIN,
2738 &candidates);
4c4b4cd2
PH
2739 if (n_candidates == 1)
2740 i = 0;
2741 else
2742 {
76a01679
JB
2743 i = ada_resolve_function (candidates, n_candidates,
2744 argvec, nargs,
2745 SYMBOL_LINKAGE_NAME (exp->
2746 elts[pc +
2747 5].
2748 symbol),
4c4b4cd2
PH
2749 context_type);
2750 if (i < 0)
2751 error ("Could not find a match for %s",
2752 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
2753 }
2754
2755 exp->elts[pc + 4].block = candidates[i].block;
2756 exp->elts[pc + 5].symbol = candidates[i].sym;
1265e4aa
JB
2757 if (innermost_block == NULL
2758 || contained_in (candidates[i].block, innermost_block))
4c4b4cd2
PH
2759 innermost_block = candidates[i].block;
2760 }
14f9c5c9
AS
2761 }
2762 break;
2763 case BINOP_ADD:
2764 case BINOP_SUB:
2765 case BINOP_MUL:
2766 case BINOP_DIV:
2767 case BINOP_REM:
2768 case BINOP_MOD:
2769 case BINOP_CONCAT:
2770 case BINOP_BITWISE_AND:
2771 case BINOP_BITWISE_IOR:
2772 case BINOP_BITWISE_XOR:
2773 case BINOP_EQUAL:
2774 case BINOP_NOTEQUAL:
2775 case BINOP_LESS:
2776 case BINOP_GTR:
2777 case BINOP_LEQ:
2778 case BINOP_GEQ:
2779 case BINOP_EXP:
2780 case UNOP_NEG:
2781 case UNOP_PLUS:
2782 case UNOP_LOGICAL_NOT:
2783 case UNOP_ABS:
2784 if (possible_user_operator_p (op, argvec))
4c4b4cd2
PH
2785 {
2786 struct ada_symbol_info *candidates;
2787 int n_candidates;
2788
2789 n_candidates =
2790 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op)),
2791 (struct block *) NULL, VAR_DOMAIN,
2792 &candidates);
2793 i = ada_resolve_function (candidates, n_candidates, argvec, nargs,
76a01679 2794 ada_decoded_op_name (op), NULL);
4c4b4cd2
PH
2795 if (i < 0)
2796 break;
2797
76a01679
JB
2798 replace_operator_with_call (expp, pc, nargs, 1,
2799 candidates[i].sym, candidates[i].block);
4c4b4cd2
PH
2800 exp = *expp;
2801 }
14f9c5c9 2802 break;
4c4b4cd2
PH
2803
2804 case OP_TYPE:
2805 return NULL;
14f9c5c9
AS
2806 }
2807
2808 *pos = pc;
2809 return evaluate_subexp_type (exp, pos);
2810}
2811
2812/* Return non-zero if formal type FTYPE matches actual type ATYPE. If
4c4b4cd2
PH
2813 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2814 a non-pointer. A type of 'void' (which is never a valid expression type)
2815 by convention matches anything. */
14f9c5c9 2816/* The term "match" here is rather loose. The match is heuristic and
4c4b4cd2 2817 liberal. FIXME: TOO liberal, in fact. */
14f9c5c9
AS
2818
2819static int
4dc81987 2820ada_type_match (struct type *ftype, struct type *atype, int may_deref)
14f9c5c9
AS
2821{
2822 CHECK_TYPEDEF (ftype);
2823 CHECK_TYPEDEF (atype);
2824
2825 if (TYPE_CODE (ftype) == TYPE_CODE_REF)
2826 ftype = TYPE_TARGET_TYPE (ftype);
2827 if (TYPE_CODE (atype) == TYPE_CODE_REF)
2828 atype = TYPE_TARGET_TYPE (atype);
2829
d2e4a39e 2830 if (TYPE_CODE (ftype) == TYPE_CODE_VOID
14f9c5c9
AS
2831 || TYPE_CODE (atype) == TYPE_CODE_VOID)
2832 return 1;
2833
d2e4a39e 2834 switch (TYPE_CODE (ftype))
14f9c5c9
AS
2835 {
2836 default:
2837 return 1;
2838 case TYPE_CODE_PTR:
2839 if (TYPE_CODE (atype) == TYPE_CODE_PTR)
4c4b4cd2
PH
2840 return ada_type_match (TYPE_TARGET_TYPE (ftype),
2841 TYPE_TARGET_TYPE (atype), 0);
d2e4a39e 2842 else
1265e4aa
JB
2843 return (may_deref
2844 && ada_type_match (TYPE_TARGET_TYPE (ftype), atype, 0));
14f9c5c9
AS
2845 case TYPE_CODE_INT:
2846 case TYPE_CODE_ENUM:
2847 case TYPE_CODE_RANGE:
2848 switch (TYPE_CODE (atype))
4c4b4cd2
PH
2849 {
2850 case TYPE_CODE_INT:
2851 case TYPE_CODE_ENUM:
2852 case TYPE_CODE_RANGE:
2853 return 1;
2854 default:
2855 return 0;
2856 }
14f9c5c9
AS
2857
2858 case TYPE_CODE_ARRAY:
d2e4a39e 2859 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
4c4b4cd2 2860 || ada_is_array_descriptor_type (atype));
14f9c5c9
AS
2861
2862 case TYPE_CODE_STRUCT:
4c4b4cd2
PH
2863 if (ada_is_array_descriptor_type (ftype))
2864 return (TYPE_CODE (atype) == TYPE_CODE_ARRAY
2865 || ada_is_array_descriptor_type (atype));
14f9c5c9 2866 else
4c4b4cd2
PH
2867 return (TYPE_CODE (atype) == TYPE_CODE_STRUCT
2868 && !ada_is_array_descriptor_type (atype));
14f9c5c9
AS
2869
2870 case TYPE_CODE_UNION:
2871 case TYPE_CODE_FLT:
2872 return (TYPE_CODE (atype) == TYPE_CODE (ftype));
2873 }
2874}
2875
2876/* Return non-zero if the formals of FUNC "sufficiently match" the
2877 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2878 may also be an enumeral, in which case it is treated as a 0-
4c4b4cd2 2879 argument function. */
14f9c5c9
AS
2880
2881static int
d2e4a39e 2882ada_args_match (struct symbol *func, struct value **actuals, int n_actuals)
14f9c5c9
AS
2883{
2884 int i;
d2e4a39e 2885 struct type *func_type = SYMBOL_TYPE (func);
14f9c5c9 2886
1265e4aa
JB
2887 if (SYMBOL_CLASS (func) == LOC_CONST
2888 && TYPE_CODE (func_type) == TYPE_CODE_ENUM)
14f9c5c9
AS
2889 return (n_actuals == 0);
2890 else if (func_type == NULL || TYPE_CODE (func_type) != TYPE_CODE_FUNC)
2891 return 0;
2892
2893 if (TYPE_NFIELDS (func_type) != n_actuals)
2894 return 0;
2895
2896 for (i = 0; i < n_actuals; i += 1)
2897 {
4c4b4cd2 2898 if (actuals[i] == NULL)
76a01679
JB
2899 return 0;
2900 else
2901 {
2902 struct type *ftype = check_typedef (TYPE_FIELD_TYPE (func_type, i));
2903 struct type *atype = check_typedef (VALUE_TYPE (actuals[i]));
4c4b4cd2 2904
76a01679
JB
2905 if (!ada_type_match (ftype, atype, 1))
2906 return 0;
2907 }
14f9c5c9
AS
2908 }
2909 return 1;
2910}
2911
2912/* False iff function type FUNC_TYPE definitely does not produce a value
2913 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2914 FUNC_TYPE is not a valid function type with a non-null return type
2915 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2916
2917static int
d2e4a39e 2918return_match (struct type *func_type, struct type *context_type)
14f9c5c9 2919{
d2e4a39e 2920 struct type *return_type;
14f9c5c9
AS
2921
2922 if (func_type == NULL)
2923 return 1;
2924
4c4b4cd2
PH
2925 if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2926 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2927 else
2928 return_type = base_type (func_type);
14f9c5c9
AS
2929 if (return_type == NULL)
2930 return 1;
2931
4c4b4cd2 2932 context_type = base_type (context_type);
14f9c5c9
AS
2933
2934 if (TYPE_CODE (return_type) == TYPE_CODE_ENUM)
2935 return context_type == NULL || return_type == context_type;
2936 else if (context_type == NULL)
2937 return TYPE_CODE (return_type) != TYPE_CODE_VOID;
2938 else
2939 return TYPE_CODE (return_type) == TYPE_CODE (context_type);
2940}
2941
2942
4c4b4cd2 2943/* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
14f9c5c9 2944 function (if any) that matches the types of the NARGS arguments in
4c4b4cd2
PH
2945 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2946 that returns that type, then eliminate matches that don't. If
2947 CONTEXT_TYPE is void and there is at least one match that does not
2948 return void, eliminate all matches that do.
2949
14f9c5c9
AS
2950 Asks the user if there is more than one match remaining. Returns -1
2951 if there is no such symbol or none is selected. NAME is used
4c4b4cd2
PH
2952 solely for messages. May re-arrange and modify SYMS in
2953 the process; the index returned is for the modified vector. */
14f9c5c9 2954
4c4b4cd2
PH
2955static int
2956ada_resolve_function (struct ada_symbol_info syms[],
2957 int nsyms, struct value **args, int nargs,
2958 const char *name, struct type *context_type)
14f9c5c9
AS
2959{
2960 int k;
4c4b4cd2 2961 int m; /* Number of hits */
d2e4a39e
AS
2962 struct type *fallback;
2963 struct type *return_type;
14f9c5c9
AS
2964
2965 return_type = context_type;
2966 if (context_type == NULL)
2967 fallback = builtin_type_void;
2968 else
2969 fallback = NULL;
2970
d2e4a39e 2971 m = 0;
14f9c5c9
AS
2972 while (1)
2973 {
2974 for (k = 0; k < nsyms; k += 1)
4c4b4cd2
PH
2975 {
2976 struct type *type = check_typedef (SYMBOL_TYPE (syms[k].sym));
2977
2978 if (ada_args_match (syms[k].sym, args, nargs)
2979 && return_match (type, return_type))
2980 {
2981 syms[m] = syms[k];
2982 m += 1;
2983 }
2984 }
14f9c5c9 2985 if (m > 0 || return_type == fallback)
4c4b4cd2 2986 break;
14f9c5c9 2987 else
4c4b4cd2 2988 return_type = fallback;
14f9c5c9
AS
2989 }
2990
2991 if (m == 0)
2992 return -1;
2993 else if (m > 1)
2994 {
2995 printf_filtered ("Multiple matches for %s\n", name);
4c4b4cd2 2996 user_select_syms (syms, m, 1);
14f9c5c9
AS
2997 return 0;
2998 }
2999 return 0;
3000}
3001
4c4b4cd2
PH
3002/* Returns true (non-zero) iff decoded name N0 should appear before N1
3003 in a listing of choices during disambiguation (see sort_choices, below).
3004 The idea is that overloadings of a subprogram name from the
3005 same package should sort in their source order. We settle for ordering
3006 such symbols by their trailing number (__N or $N). */
3007
14f9c5c9 3008static int
4c4b4cd2 3009encoded_ordered_before (char *N0, char *N1)
14f9c5c9
AS
3010{
3011 if (N1 == NULL)
3012 return 0;
3013 else if (N0 == NULL)
3014 return 1;
3015 else
3016 {
3017 int k0, k1;
d2e4a39e 3018 for (k0 = strlen (N0) - 1; k0 > 0 && isdigit (N0[k0]); k0 -= 1)
4c4b4cd2 3019 ;
d2e4a39e 3020 for (k1 = strlen (N1) - 1; k1 > 0 && isdigit (N1[k1]); k1 -= 1)
4c4b4cd2 3021 ;
d2e4a39e 3022 if ((N0[k0] == '_' || N0[k0] == '$') && N0[k0 + 1] != '\000'
4c4b4cd2
PH
3023 && (N1[k1] == '_' || N1[k1] == '$') && N1[k1 + 1] != '\000')
3024 {
3025 int n0, n1;
3026 n0 = k0;
3027 while (N0[n0] == '_' && n0 > 0 && N0[n0 - 1] == '_')
3028 n0 -= 1;
3029 n1 = k1;
3030 while (N1[n1] == '_' && n1 > 0 && N1[n1 - 1] == '_')
3031 n1 -= 1;
3032 if (n0 == n1 && strncmp (N0, N1, n0) == 0)
3033 return (atoi (N0 + k0 + 1) < atoi (N1 + k1 + 1));
3034 }
14f9c5c9
AS
3035 return (strcmp (N0, N1) < 0);
3036 }
3037}
d2e4a39e 3038
4c4b4cd2
PH
3039/* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3040 encoded names. */
3041
d2e4a39e 3042static void
4c4b4cd2 3043sort_choices (struct ada_symbol_info syms[], int nsyms)
14f9c5c9 3044{
4c4b4cd2 3045 int i;
d2e4a39e 3046 for (i = 1; i < nsyms; i += 1)
14f9c5c9 3047 {
4c4b4cd2 3048 struct ada_symbol_info sym = syms[i];
14f9c5c9
AS
3049 int j;
3050
d2e4a39e 3051 for (j = i - 1; j >= 0; j -= 1)
4c4b4cd2
PH
3052 {
3053 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms[j].sym),
3054 SYMBOL_LINKAGE_NAME (sym.sym)))
3055 break;
3056 syms[j + 1] = syms[j];
3057 }
d2e4a39e 3058 syms[j + 1] = sym;
14f9c5c9
AS
3059 }
3060}
3061
4c4b4cd2
PH
3062/* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3063 by asking the user (if necessary), returning the number selected,
3064 and setting the first elements of SYMS items. Error if no symbols
3065 selected. */
14f9c5c9
AS
3066
3067/* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
4c4b4cd2 3068 to be re-integrated one of these days. */
14f9c5c9
AS
3069
3070int
4c4b4cd2 3071user_select_syms (struct ada_symbol_info *syms, int nsyms, int max_results)
14f9c5c9
AS
3072{
3073 int i;
d2e4a39e 3074 int *chosen = (int *) alloca (sizeof (int) * nsyms);
14f9c5c9
AS
3075 int n_chosen;
3076 int first_choice = (max_results == 1) ? 1 : 2;
3077
3078 if (max_results < 1)
3079 error ("Request to select 0 symbols!");
3080 if (nsyms <= 1)
3081 return nsyms;
3082
d2e4a39e 3083 printf_unfiltered ("[0] cancel\n");
14f9c5c9 3084 if (max_results > 1)
d2e4a39e 3085 printf_unfiltered ("[1] all\n");
14f9c5c9 3086
4c4b4cd2 3087 sort_choices (syms, nsyms);
14f9c5c9
AS
3088
3089 for (i = 0; i < nsyms; i += 1)
3090 {
4c4b4cd2
PH
3091 if (syms[i].sym == NULL)
3092 continue;
3093
3094 if (SYMBOL_CLASS (syms[i].sym) == LOC_BLOCK)
3095 {
76a01679
JB
3096 struct symtab_and_line sal =
3097 find_function_start_sal (syms[i].sym, 1);
3098 printf_unfiltered ("[%d] %s at %s:%d\n", i + first_choice,
4c4b4cd2 3099 SYMBOL_PRINT_NAME (syms[i].sym),
76a01679
JB
3100 sal.symtab ==
3101 NULL ? "<no source file available>" : sal.
3102 symtab->filename, sal.line);
4c4b4cd2
PH
3103 continue;
3104 }
d2e4a39e 3105 else
4c4b4cd2
PH
3106 {
3107 int is_enumeral =
3108 (SYMBOL_CLASS (syms[i].sym) == LOC_CONST
3109 && SYMBOL_TYPE (syms[i].sym) != NULL
3110 && TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) == TYPE_CODE_ENUM);
3111 struct symtab *symtab = symtab_for_sym (syms[i].sym);
3112
3113 if (SYMBOL_LINE (syms[i].sym) != 0 && symtab != NULL)
3114 printf_unfiltered ("[%d] %s at %s:%d\n",
3115 i + first_choice,
3116 SYMBOL_PRINT_NAME (syms[i].sym),
3117 symtab->filename, SYMBOL_LINE (syms[i].sym));
76a01679
JB
3118 else if (is_enumeral
3119 && TYPE_NAME (SYMBOL_TYPE (syms[i].sym)) != NULL)
4c4b4cd2
PH
3120 {
3121 printf_unfiltered ("[%d] ", i + first_choice);
76a01679
JB
3122 ada_print_type (SYMBOL_TYPE (syms[i].sym), NULL,
3123 gdb_stdout, -1, 0);
4c4b4cd2
PH
3124 printf_unfiltered ("'(%s) (enumeral)\n",
3125 SYMBOL_PRINT_NAME (syms[i].sym));
3126 }
3127 else if (symtab != NULL)
3128 printf_unfiltered (is_enumeral
3129 ? "[%d] %s in %s (enumeral)\n"
3130 : "[%d] %s at %s:?\n",
3131 i + first_choice,
3132 SYMBOL_PRINT_NAME (syms[i].sym),
3133 symtab->filename);
3134 else
3135 printf_unfiltered (is_enumeral
3136 ? "[%d] %s (enumeral)\n"
3137 : "[%d] %s at ?\n",
3138 i + first_choice,
3139 SYMBOL_PRINT_NAME (syms[i].sym));
3140 }
14f9c5c9 3141 }
d2e4a39e 3142
14f9c5c9 3143 n_chosen = get_selections (chosen, nsyms, max_results, max_results > 1,
4c4b4cd2 3144 "overload-choice");
14f9c5c9
AS
3145
3146 for (i = 0; i < n_chosen; i += 1)
4c4b4cd2 3147 syms[i] = syms[chosen[i]];
14f9c5c9
AS
3148
3149 return n_chosen;
3150}
3151
3152/* Read and validate a set of numeric choices from the user in the
4c4b4cd2 3153 range 0 .. N_CHOICES-1. Place the results in increasing
14f9c5c9
AS
3154 order in CHOICES[0 .. N-1], and return N.
3155
3156 The user types choices as a sequence of numbers on one line
3157 separated by blanks, encoding them as follows:
3158
4c4b4cd2 3159 + A choice of 0 means to cancel the selection, throwing an error.
14f9c5c9
AS
3160 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3161 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3162
4c4b4cd2 3163 The user is not allowed to choose more than MAX_RESULTS values.
14f9c5c9
AS
3164
3165 ANNOTATION_SUFFIX, if present, is used to annotate the input
4c4b4cd2 3166 prompts (for use with the -f switch). */
14f9c5c9
AS
3167
3168int
d2e4a39e 3169get_selections (int *choices, int n_choices, int max_results,
4c4b4cd2 3170 int is_all_choice, char *annotation_suffix)
14f9c5c9 3171{
d2e4a39e
AS
3172 char *args;
3173 const char *prompt;
14f9c5c9
AS
3174 int n_chosen;
3175 int first_choice = is_all_choice ? 2 : 1;
d2e4a39e 3176
14f9c5c9
AS
3177 prompt = getenv ("PS2");
3178 if (prompt == NULL)
3179 prompt = ">";
3180
3181 printf_unfiltered ("%s ", prompt);
3182 gdb_flush (gdb_stdout);
3183
3184 args = command_line_input ((char *) NULL, 0, annotation_suffix);
d2e4a39e 3185
14f9c5c9
AS
3186 if (args == NULL)
3187 error_no_arg ("one or more choice numbers");
3188
3189 n_chosen = 0;
76a01679 3190
4c4b4cd2
PH
3191 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3192 order, as given in args. Choices are validated. */
14f9c5c9
AS
3193 while (1)
3194 {
d2e4a39e 3195 char *args2;
14f9c5c9
AS
3196 int choice, j;
3197
3198 while (isspace (*args))
4c4b4cd2 3199 args += 1;
14f9c5c9 3200 if (*args == '\0' && n_chosen == 0)
4c4b4cd2 3201 error_no_arg ("one or more choice numbers");
14f9c5c9 3202 else if (*args == '\0')
4c4b4cd2 3203 break;
14f9c5c9
AS
3204
3205 choice = strtol (args, &args2, 10);
d2e4a39e 3206 if (args == args2 || choice < 0
4c4b4cd2
PH
3207 || choice > n_choices + first_choice - 1)
3208 error ("Argument must be choice number");
14f9c5c9
AS
3209 args = args2;
3210
d2e4a39e 3211 if (choice == 0)
4c4b4cd2 3212 error ("cancelled");
14f9c5c9
AS
3213
3214 if (choice < first_choice)
4c4b4cd2
PH
3215 {
3216 n_chosen = n_choices;
3217 for (j = 0; j < n_choices; j += 1)
3218 choices[j] = j;
3219 break;
3220 }
14f9c5c9
AS
3221 choice -= first_choice;
3222
d2e4a39e 3223 for (j = n_chosen - 1; j >= 0 && choice < choices[j]; j -= 1)
4c4b4cd2
PH
3224 {
3225 }
14f9c5c9
AS
3226
3227 if (j < 0 || choice != choices[j])
4c4b4cd2
PH
3228 {
3229 int k;
3230 for (k = n_chosen - 1; k > j; k -= 1)
3231 choices[k + 1] = choices[k];
3232 choices[j + 1] = choice;
3233 n_chosen += 1;
3234 }
14f9c5c9
AS
3235 }
3236
3237 if (n_chosen > max_results)
3238 error ("Select no more than %d of the above", max_results);
d2e4a39e 3239
14f9c5c9
AS
3240 return n_chosen;
3241}
3242
4c4b4cd2
PH
3243/* Replace the operator of length OPLEN at position PC in *EXPP with a call
3244 on the function identified by SYM and BLOCK, and taking NARGS
3245 arguments. Update *EXPP as needed to hold more space. */
14f9c5c9
AS
3246
3247static void
d2e4a39e 3248replace_operator_with_call (struct expression **expp, int pc, int nargs,
4c4b4cd2
PH
3249 int oplen, struct symbol *sym,
3250 struct block *block)
14f9c5c9
AS
3251{
3252 /* A new expression, with 6 more elements (3 for funcall, 4 for function
4c4b4cd2 3253 symbol, -oplen for operator being replaced). */
d2e4a39e 3254 struct expression *newexp = (struct expression *)
14f9c5c9 3255 xmalloc (sizeof (struct expression)
4c4b4cd2 3256 + EXP_ELEM_TO_BYTES ((*expp)->nelts + 7 - oplen));
d2e4a39e 3257 struct expression *exp = *expp;
14f9c5c9
AS
3258
3259 newexp->nelts = exp->nelts + 7 - oplen;
3260 newexp->language_defn = exp->language_defn;
3261 memcpy (newexp->elts, exp->elts, EXP_ELEM_TO_BYTES (pc));
d2e4a39e 3262 memcpy (newexp->elts + pc + 7, exp->elts + pc + oplen,
4c4b4cd2 3263 EXP_ELEM_TO_BYTES (exp->nelts - pc - oplen));
14f9c5c9
AS
3264
3265 newexp->elts[pc].opcode = newexp->elts[pc + 2].opcode = OP_FUNCALL;
3266 newexp->elts[pc + 1].longconst = (LONGEST) nargs;
3267
3268 newexp->elts[pc + 3].opcode = newexp->elts[pc + 6].opcode = OP_VAR_VALUE;
3269 newexp->elts[pc + 4].block = block;
3270 newexp->elts[pc + 5].symbol = sym;
3271
3272 *expp = newexp;
aacb1f0a 3273 xfree (exp);
d2e4a39e 3274}
14f9c5c9
AS
3275
3276/* Type-class predicates */
3277
4c4b4cd2
PH
3278/* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3279 or FLOAT). */
14f9c5c9
AS
3280
3281static int
d2e4a39e 3282numeric_type_p (struct type *type)
14f9c5c9
AS
3283{
3284 if (type == NULL)
3285 return 0;
d2e4a39e
AS
3286 else
3287 {
3288 switch (TYPE_CODE (type))
4c4b4cd2
PH
3289 {
3290 case TYPE_CODE_INT:
3291 case TYPE_CODE_FLT:
3292 return 1;
3293 case TYPE_CODE_RANGE:
3294 return (type == TYPE_TARGET_TYPE (type)
3295 || numeric_type_p (TYPE_TARGET_TYPE (type)));
3296 default:
3297 return 0;
3298 }
d2e4a39e 3299 }
14f9c5c9
AS
3300}
3301
4c4b4cd2 3302/* True iff TYPE is integral (an INT or RANGE of INTs). */
14f9c5c9
AS
3303
3304static int
d2e4a39e 3305integer_type_p (struct type *type)
14f9c5c9
AS
3306{
3307 if (type == NULL)
3308 return 0;
d2e4a39e
AS
3309 else
3310 {
3311 switch (TYPE_CODE (type))
4c4b4cd2
PH
3312 {
3313 case TYPE_CODE_INT:
3314 return 1;
3315 case TYPE_CODE_RANGE:
3316 return (type == TYPE_TARGET_TYPE (type)
3317 || integer_type_p (TYPE_TARGET_TYPE (type)));
3318 default:
3319 return 0;
3320 }
d2e4a39e 3321 }
14f9c5c9
AS
3322}
3323
4c4b4cd2 3324/* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
14f9c5c9
AS
3325
3326static int
d2e4a39e 3327scalar_type_p (struct type *type)
14f9c5c9
AS
3328{
3329 if (type == NULL)
3330 return 0;
d2e4a39e
AS
3331 else
3332 {
3333 switch (TYPE_CODE (type))
4c4b4cd2
PH
3334 {
3335 case TYPE_CODE_INT:
3336 case TYPE_CODE_RANGE:
3337 case TYPE_CODE_ENUM:
3338 case TYPE_CODE_FLT:
3339 return 1;
3340 default:
3341 return 0;
3342 }
d2e4a39e 3343 }
14f9c5c9
AS
3344}
3345
4c4b4cd2 3346/* True iff TYPE is discrete (INT, RANGE, ENUM). */
14f9c5c9
AS
3347
3348static int
d2e4a39e 3349discrete_type_p (struct type *type)
14f9c5c9
AS
3350{
3351 if (type == NULL)
3352 return 0;
d2e4a39e
AS
3353 else
3354 {
3355 switch (TYPE_CODE (type))
4c4b4cd2
PH
3356 {
3357 case TYPE_CODE_INT:
3358 case TYPE_CODE_RANGE:
3359 case TYPE_CODE_ENUM:
3360 return 1;
3361 default:
3362 return 0;
3363 }
d2e4a39e 3364 }
14f9c5c9
AS
3365}
3366
4c4b4cd2
PH
3367/* Returns non-zero if OP with operands in the vector ARGS could be
3368 a user-defined function. Errs on the side of pre-defined operators
3369 (i.e., result 0). */
14f9c5c9
AS
3370
3371static int
d2e4a39e 3372possible_user_operator_p (enum exp_opcode op, struct value *args[])
14f9c5c9 3373{
76a01679 3374 struct type *type0 =
4c4b4cd2 3375 (args[0] == NULL) ? NULL : check_typedef (VALUE_TYPE (args[0]));
d2e4a39e 3376 struct type *type1 =
14f9c5c9 3377 (args[1] == NULL) ? NULL : check_typedef (VALUE_TYPE (args[1]));
d2e4a39e 3378
4c4b4cd2
PH
3379 if (type0 == NULL)
3380 return 0;
3381
14f9c5c9
AS
3382 switch (op)
3383 {
3384 default:
3385 return 0;
3386
3387 case BINOP_ADD:
3388 case BINOP_SUB:
3389 case BINOP_MUL:
3390 case BINOP_DIV:
d2e4a39e 3391 return (!(numeric_type_p (type0) && numeric_type_p (type1)));
14f9c5c9
AS
3392
3393 case BINOP_REM:
3394 case BINOP_MOD:
3395 case BINOP_BITWISE_AND:
3396 case BINOP_BITWISE_IOR:
3397 case BINOP_BITWISE_XOR:
d2e4a39e 3398 return (!(integer_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3399
3400 case BINOP_EQUAL:
3401 case BINOP_NOTEQUAL:
3402 case BINOP_LESS:
3403 case BINOP_GTR:
3404 case BINOP_LEQ:
3405 case BINOP_GEQ:
d2e4a39e 3406 return (!(scalar_type_p (type0) && scalar_type_p (type1)));
14f9c5c9
AS
3407
3408 case BINOP_CONCAT:
1265e4aa
JB
3409 return
3410 ((TYPE_CODE (type0) != TYPE_CODE_ARRAY
3411 && (TYPE_CODE (type0) != TYPE_CODE_PTR
3412 || TYPE_CODE (TYPE_TARGET_TYPE (type0)) != TYPE_CODE_ARRAY))
3413 || (TYPE_CODE (type1) != TYPE_CODE_ARRAY
3414 && (TYPE_CODE (type1) != TYPE_CODE_PTR
3415 || (TYPE_CODE (TYPE_TARGET_TYPE (type1)) !=
3416 TYPE_CODE_ARRAY))));
14f9c5c9
AS
3417
3418 case BINOP_EXP:
d2e4a39e 3419 return (!(numeric_type_p (type0) && integer_type_p (type1)));
14f9c5c9
AS
3420
3421 case UNOP_NEG:
3422 case UNOP_PLUS:
3423 case UNOP_LOGICAL_NOT:
d2e4a39e
AS
3424 case UNOP_ABS:
3425 return (!numeric_type_p (type0));
14f9c5c9
AS
3426
3427 }
3428}
3429\f
4c4b4cd2 3430 /* Renaming */
14f9c5c9 3431
4c4b4cd2
PH
3432/* NOTE: In the following, we assume that a renaming type's name may
3433 have an ___XD suffix. It would be nice if this went away at some
3434 point. */
14f9c5c9
AS
3435
3436/* If TYPE encodes a renaming, returns the renaming suffix, which
4c4b4cd2
PH
3437 is XR for an object renaming, XRP for a procedure renaming, XRE for
3438 an exception renaming, and XRS for a subprogram renaming. Returns
3439 NULL if NAME encodes none of these. */
3440
d2e4a39e
AS
3441const char *
3442ada_renaming_type (struct type *type)
14f9c5c9
AS
3443{
3444 if (type != NULL && TYPE_CODE (type) == TYPE_CODE_ENUM)
3445 {
d2e4a39e
AS
3446 const char *name = type_name_no_tag (type);
3447 const char *suffix = (name == NULL) ? NULL : strstr (name, "___XR");
3448 if (suffix == NULL
4c4b4cd2
PH
3449 || (suffix[5] != '\000' && strchr ("PES_", suffix[5]) == NULL))
3450 return NULL;
14f9c5c9 3451 else
4c4b4cd2 3452 return suffix + 3;
14f9c5c9
AS
3453 }
3454 else
3455 return NULL;
3456}
3457
4c4b4cd2
PH
3458/* Return non-zero iff SYM encodes an object renaming. */
3459
14f9c5c9 3460int
d2e4a39e 3461ada_is_object_renaming (struct symbol *sym)
14f9c5c9 3462{
d2e4a39e
AS
3463 const char *renaming_type = ada_renaming_type (SYMBOL_TYPE (sym));
3464 return renaming_type != NULL
14f9c5c9
AS
3465 && (renaming_type[2] == '\0' || renaming_type[2] == '_');
3466}
3467
3468/* Assuming that SYM encodes a non-object renaming, returns the original
4c4b4cd2
PH
3469 name of the renamed entity. The name is good until the end of
3470 parsing. */
3471
3472char *
d2e4a39e 3473ada_simple_renamed_entity (struct symbol *sym)
14f9c5c9 3474{
d2e4a39e
AS
3475 struct type *type;
3476 const char *raw_name;
14f9c5c9 3477 int len;
d2e4a39e 3478 char *result;
14f9c5c9
AS
3479
3480 type = SYMBOL_TYPE (sym);
3481 if (type == NULL || TYPE_NFIELDS (type) < 1)
3482 error ("Improperly encoded renaming.");
3483
3484 raw_name = TYPE_FIELD_NAME (type, 0);
3485 len = (raw_name == NULL ? 0 : strlen (raw_name)) - 5;
3486 if (len <= 0)
3487 error ("Improperly encoded renaming.");
3488
3489 result = xmalloc (len + 1);
14f9c5c9
AS
3490 strncpy (result, raw_name, len);
3491 result[len] = '\000';
3492 return result;
3493}
14f9c5c9 3494\f
d2e4a39e 3495
4c4b4cd2 3496 /* Evaluation: Function Calls */
14f9c5c9 3497
4c4b4cd2
PH
3498/* Return an lvalue containing the value VAL. This is the identity on
3499 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3500 on the stack, using and updating *SP as the stack pointer, and
3501 returning an lvalue whose VALUE_ADDRESS points to the copy. */
14f9c5c9 3502
d2e4a39e 3503static struct value *
4c4b4cd2 3504ensure_lval (struct value *val, CORE_ADDR *sp)
14f9c5c9
AS
3505{
3506 CORE_ADDR old_sp = *sp;
3507
4c4b4cd2
PH
3508 if (VALUE_LVAL (val))
3509 return val;
3510
3511 if (DEPRECATED_STACK_ALIGN_P ())
3512 *sp = push_bytes (*sp, VALUE_CONTENTS_RAW (val),
76a01679
JB
3513 DEPRECATED_STACK_ALIGN
3514 (TYPE_LENGTH (check_typedef (VALUE_TYPE (val)))));
4c4b4cd2
PH
3515 else
3516 *sp = push_bytes (*sp, VALUE_CONTENTS_RAW (val),
3517 TYPE_LENGTH (check_typedef (VALUE_TYPE (val))));
14f9c5c9
AS
3518
3519 VALUE_LVAL (val) = lval_memory;
3520 if (INNER_THAN (1, 2))
3521 VALUE_ADDRESS (val) = *sp;
3522 else
3523 VALUE_ADDRESS (val) = old_sp;
3524
3525 return val;
3526}
3527
3528/* Return the value ACTUAL, converted to be an appropriate value for a
3529 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3530 allocating any necessary descriptors (fat pointers), or copies of
4c4b4cd2 3531 values not residing in memory, updating it as needed. */
14f9c5c9 3532
d2e4a39e
AS
3533static struct value *
3534convert_actual (struct value *actual, struct type *formal_type0,
4c4b4cd2 3535 CORE_ADDR *sp)
14f9c5c9 3536{
d2e4a39e
AS
3537 struct type *actual_type = check_typedef (VALUE_TYPE (actual));
3538 struct type *formal_type = check_typedef (formal_type0);
3539 struct type *formal_target =
3540 TYPE_CODE (formal_type) == TYPE_CODE_PTR
3541 ? check_typedef (TYPE_TARGET_TYPE (formal_type)) : formal_type;
3542 struct type *actual_target =
3543 TYPE_CODE (actual_type) == TYPE_CODE_PTR
3544 ? check_typedef (TYPE_TARGET_TYPE (actual_type)) : actual_type;
14f9c5c9 3545
4c4b4cd2 3546 if (ada_is_array_descriptor_type (formal_target)
14f9c5c9
AS
3547 && TYPE_CODE (actual_target) == TYPE_CODE_ARRAY)
3548 return make_array_descriptor (formal_type, actual, sp);
3549 else if (TYPE_CODE (formal_type) == TYPE_CODE_PTR)
3550 {
3551 if (TYPE_CODE (formal_target) == TYPE_CODE_ARRAY
4c4b4cd2
PH
3552 && ada_is_array_descriptor_type (actual_target))
3553 return desc_data (actual);
14f9c5c9 3554 else if (TYPE_CODE (actual_type) != TYPE_CODE_PTR)
4c4b4cd2
PH
3555 {
3556 if (VALUE_LVAL (actual) != lval_memory)
3557 {
3558 struct value *val;
3559 actual_type = check_typedef (VALUE_TYPE (actual));
3560 val = allocate_value (actual_type);
3561 memcpy ((char *) VALUE_CONTENTS_RAW (val),
3562 (char *) VALUE_CONTENTS (actual),
3563 TYPE_LENGTH (actual_type));
3564 actual = ensure_lval (val, sp);
3565 }
3566 return value_addr (actual);
3567 }
14f9c5c9
AS
3568 }
3569 else if (TYPE_CODE (actual_type) == TYPE_CODE_PTR)
3570 return ada_value_ind (actual);
3571
3572 return actual;
3573}
3574
3575
4c4b4cd2
PH
3576/* Push a descriptor of type TYPE for array value ARR on the stack at
3577 *SP, updating *SP to reflect the new descriptor. Return either
14f9c5c9 3578 an lvalue representing the new descriptor, or (if TYPE is a pointer-
4c4b4cd2
PH
3579 to-descriptor type rather than a descriptor type), a struct value *
3580 representing a pointer to this descriptor. */
14f9c5c9 3581
d2e4a39e
AS
3582static struct value *
3583make_array_descriptor (struct type *type, struct value *arr, CORE_ADDR *sp)
14f9c5c9 3584{
d2e4a39e
AS
3585 struct type *bounds_type = desc_bounds_type (type);
3586 struct type *desc_type = desc_base_type (type);
3587 struct value *descriptor = allocate_value (desc_type);
3588 struct value *bounds = allocate_value (bounds_type);
14f9c5c9 3589 int i;
d2e4a39e 3590
14f9c5c9
AS
3591 for (i = ada_array_arity (check_typedef (VALUE_TYPE (arr))); i > 0; i -= 1)
3592 {
3593 modify_general_field (VALUE_CONTENTS (bounds),
4c4b4cd2
PH
3594 value_as_long (ada_array_bound (arr, i, 0)),
3595 desc_bound_bitpos (bounds_type, i, 0),
3596 desc_bound_bitsize (bounds_type, i, 0));
14f9c5c9 3597 modify_general_field (VALUE_CONTENTS (bounds),
4c4b4cd2
PH
3598 value_as_long (ada_array_bound (arr, i, 1)),
3599 desc_bound_bitpos (bounds_type, i, 1),
3600 desc_bound_bitsize (bounds_type, i, 1));
14f9c5c9 3601 }
d2e4a39e 3602
4c4b4cd2 3603 bounds = ensure_lval (bounds, sp);
d2e4a39e 3604
14f9c5c9 3605 modify_general_field (VALUE_CONTENTS (descriptor),
76a01679
JB
3606 VALUE_ADDRESS (ensure_lval (arr, sp)),
3607 fat_pntr_data_bitpos (desc_type),
3608 fat_pntr_data_bitsize (desc_type));
4c4b4cd2 3609
14f9c5c9 3610 modify_general_field (VALUE_CONTENTS (descriptor),
4c4b4cd2
PH
3611 VALUE_ADDRESS (bounds),
3612 fat_pntr_bounds_bitpos (desc_type),
3613 fat_pntr_bounds_bitsize (desc_type));
14f9c5c9 3614
4c4b4cd2 3615 descriptor = ensure_lval (descriptor, sp);
14f9c5c9
AS
3616
3617 if (TYPE_CODE (type) == TYPE_CODE_PTR)
3618 return value_addr (descriptor);
3619 else
3620 return descriptor;
3621}
3622
3623
4c4b4cd2 3624/* Assuming a dummy frame has been established on the target, perform any
14f9c5c9 3625 conversions needed for calling function FUNC on the NARGS actual
4c4b4cd2 3626 parameters in ARGS, other than standard C conversions. Does
14f9c5c9 3627 nothing if FUNC does not have Ada-style prototype data, or if NARGS
4c4b4cd2 3628 does not match the number of arguments expected. Use *SP as a
14f9c5c9 3629 stack pointer for additional data that must be pushed, updating its
4c4b4cd2 3630 value as needed. */
14f9c5c9
AS
3631
3632void
d2e4a39e 3633ada_convert_actuals (struct value *func, int nargs, struct value *args[],
4c4b4cd2 3634 CORE_ADDR *sp)
14f9c5c9
AS
3635{
3636 int i;
3637
d2e4a39e 3638 if (TYPE_NFIELDS (VALUE_TYPE (func)) == 0
14f9c5c9
AS
3639 || nargs != TYPE_NFIELDS (VALUE_TYPE (func)))
3640 return;
3641
3642 for (i = 0; i < nargs; i += 1)
d2e4a39e
AS
3643 args[i] =
3644 convert_actual (args[i], TYPE_FIELD_TYPE (VALUE_TYPE (func), i), sp);
14f9c5c9 3645}
14f9c5c9 3646\f
76a01679 3647 /* Experimental Symbol Cache Module */
d2e4a39e 3648
96d887e8
PH
3649/* This module may well have been OBE, due to improvements in the
3650 symbol-table module. So until proven otherwise, it is disabled in
3651 the submitted public code, and may be removed from all sources
3652 in the future. */
3653
3654#ifdef GNAT_GDB
3655
4c4b4cd2
PH
3656/* This section implements a simple, fixed-sized hash table for those
3657 Ada-mode symbols that get looked up in the course of executing the user's
3658 commands. The size is fixed on the grounds that there are not
3659 likely to be all that many symbols looked up during any given
3660 session, regardless of the size of the symbol table. If we decide
3661 to go to a resizable table, let's just use the stuff from libiberty
3662 instead. */
14f9c5c9 3663
4c4b4cd2 3664#define HASH_SIZE 1009
14f9c5c9 3665
76a01679
JB
3666struct cache_entry
3667{
4c4b4cd2
PH
3668 const char *name;
3669 domain_enum namespace;
3670 struct symbol *sym;
3671 struct symtab *symtab;
3672 struct block *block;
3673 struct cache_entry *next;
3674};
14f9c5c9 3675
4c4b4cd2 3676static struct obstack cache_space;
14f9c5c9 3677
4c4b4cd2 3678static struct cache_entry *cache[HASH_SIZE];
14f9c5c9 3679
4c4b4cd2 3680/* Clear all entries from the symbol cache. */
14f9c5c9 3681
4c4b4cd2
PH
3682void
3683clear_ada_sym_cache (void)
3684{
3685 obstack_free (&cache_space, NULL);
3686 obstack_init (&cache_space);
3687 memset (cache, '\000', sizeof (cache));
3688}
14f9c5c9 3689
4c4b4cd2
PH
3690static struct cache_entry **
3691find_entry (const char *name, domain_enum namespace)
14f9c5c9 3692{
4c4b4cd2
PH
3693 int h = msymbol_hash (name) % HASH_SIZE;
3694 struct cache_entry **e;
3695 for (e = &cache[h]; *e != NULL; e = &(*e)->next)
3696 {
3697 if (namespace == (*e)->namespace && strcmp (name, (*e)->name) == 0)
76a01679 3698 return e;
4c4b4cd2
PH
3699 }
3700 return NULL;
14f9c5c9 3701}
d2e4a39e 3702
4c4b4cd2
PH
3703/* Return (in SYM) the last cached definition for global or static symbol NAME
3704 in namespace DOMAIN. Returns 1 if entry found, 0 otherwise.
3705 If SYMTAB is non-NULL, store the symbol
3706 table in which the symbol was found there, or NULL if not found.
3707 *BLOCK is set to the block in which NAME is found. */
14f9c5c9 3708
14f9c5c9 3709static int
4c4b4cd2 3710lookup_cached_symbol (const char *name, domain_enum namespace,
76a01679
JB
3711 struct symbol **sym, struct block **block,
3712 struct symtab **symtab)
14f9c5c9 3713{
4c4b4cd2
PH
3714 struct cache_entry **e = find_entry (name, namespace);
3715 if (e == NULL)
3716 return 0;
3717 if (sym != NULL)
3718 *sym = (*e)->sym;
3719 if (block != NULL)
3720 *block = (*e)->block;
3721 if (symtab != NULL)
3722 *symtab = (*e)->symtab;
3723 return 1;
3724}
14f9c5c9 3725
4c4b4cd2
PH
3726/* Set the cached definition of NAME in DOMAIN to SYM in block
3727 BLOCK and symbol table SYMTAB. */
3728
3729static void
3730cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
76a01679 3731 struct block *block, struct symtab *symtab)
4c4b4cd2
PH
3732{
3733 int h = msymbol_hash (name) % HASH_SIZE;
3734 char *copy;
3735 struct cache_entry *e =
76a01679 3736 (struct cache_entry *) obstack_alloc (&cache_space, sizeof (*e));
4c4b4cd2
PH
3737 e->next = cache[h];
3738 cache[h] = e;
3739 e->name = copy = obstack_alloc (&cache_space, strlen (name) + 1);
3740 strcpy (copy, name);
3741 e->sym = sym;
3742 e->namespace = namespace;
3743 e->symtab = symtab;
3744 e->block = block;
3745}
96d887e8
PH
3746
3747#else
3748static int
3749lookup_cached_symbol (const char *name, domain_enum namespace,
76a01679
JB
3750 struct symbol **sym, struct block **block,
3751 struct symtab **symtab)
96d887e8
PH
3752{
3753 return 0;
3754}
3755
3756static void
3757cache_symbol (const char *name, domain_enum namespace, struct symbol *sym,
76a01679 3758 struct block *block, struct symtab *symtab)
96d887e8
PH
3759{
3760}
76a01679 3761#endif /* GNAT_GDB */
4c4b4cd2
PH
3762\f
3763 /* Symbol Lookup */
3764
3765/* Return the result of a standard (literal, C-like) lookup of NAME in
3766 given DOMAIN, visible from lexical block BLOCK. */
3767
3768static struct symbol *
3769standard_lookup (const char *name, const struct block *block,
3770 domain_enum domain)
3771{
3772 struct symbol *sym;
3773 struct symtab *symtab;
3774
3775 if (lookup_cached_symbol (name, domain, &sym, NULL, NULL))
3776 return sym;
76a01679
JB
3777 sym =
3778 lookup_symbol_in_language (name, block, domain, language_c, 0, &symtab);
4c4b4cd2
PH
3779 cache_symbol (name, domain, sym, block_found, symtab);
3780 return sym;
3781}
3782
3783
3784/* Non-zero iff there is at least one non-function/non-enumeral symbol
3785 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3786 since they contend in overloading in the same way. */
3787static int
3788is_nonfunction (struct ada_symbol_info syms[], int n)
3789{
3790 int i;
3791
3792 for (i = 0; i < n; i += 1)
3793 if (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_FUNC
3794 && (TYPE_CODE (SYMBOL_TYPE (syms[i].sym)) != TYPE_CODE_ENUM
3795 || SYMBOL_CLASS (syms[i].sym) != LOC_CONST))
14f9c5c9
AS
3796 return 1;
3797
3798 return 0;
3799}
3800
3801/* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
4c4b4cd2 3802 struct types. Otherwise, they may not. */
14f9c5c9
AS
3803
3804static int
d2e4a39e 3805equiv_types (struct type *type0, struct type *type1)
14f9c5c9 3806{
d2e4a39e 3807 if (type0 == type1)
14f9c5c9 3808 return 1;
d2e4a39e 3809 if (type0 == NULL || type1 == NULL
14f9c5c9
AS
3810 || TYPE_CODE (type0) != TYPE_CODE (type1))
3811 return 0;
d2e4a39e 3812 if ((TYPE_CODE (type0) == TYPE_CODE_STRUCT
14f9c5c9
AS
3813 || TYPE_CODE (type0) == TYPE_CODE_ENUM)
3814 && ada_type_name (type0) != NULL && ada_type_name (type1) != NULL
4c4b4cd2 3815 && strcmp (ada_type_name (type0), ada_type_name (type1)) == 0)
14f9c5c9 3816 return 1;
d2e4a39e 3817
14f9c5c9
AS
3818 return 0;
3819}
3820
3821/* True iff SYM0 represents the same entity as SYM1, or one that is
4c4b4cd2 3822 no more defined than that of SYM1. */
14f9c5c9
AS
3823
3824static int
d2e4a39e 3825lesseq_defined_than (struct symbol *sym0, struct symbol *sym1)
14f9c5c9
AS
3826{
3827 if (sym0 == sym1)
3828 return 1;
176620f1 3829 if (SYMBOL_DOMAIN (sym0) != SYMBOL_DOMAIN (sym1)
14f9c5c9
AS
3830 || SYMBOL_CLASS (sym0) != SYMBOL_CLASS (sym1))
3831 return 0;
3832
d2e4a39e 3833 switch (SYMBOL_CLASS (sym0))
14f9c5c9
AS
3834 {
3835 case LOC_UNDEF:
3836 return 1;
3837 case LOC_TYPEDEF:
3838 {
4c4b4cd2
PH
3839 struct type *type0 = SYMBOL_TYPE (sym0);
3840 struct type *type1 = SYMBOL_TYPE (sym1);
3841 char *name0 = SYMBOL_LINKAGE_NAME (sym0);
3842 char *name1 = SYMBOL_LINKAGE_NAME (sym1);
3843 int len0 = strlen (name0);
3844 return
3845 TYPE_CODE (type0) == TYPE_CODE (type1)
3846 && (equiv_types (type0, type1)
3847 || (len0 < strlen (name1) && strncmp (name0, name1, len0) == 0
3848 && strncmp (name1 + len0, "___XV", 5) == 0));
14f9c5c9
AS
3849 }
3850 case LOC_CONST:
3851 return SYMBOL_VALUE (sym0) == SYMBOL_VALUE (sym1)
4c4b4cd2 3852 && equiv_types (SYMBOL_TYPE (sym0), SYMBOL_TYPE (sym1));
d2e4a39e
AS
3853 default:
3854 return 0;
14f9c5c9
AS
3855 }
3856}
3857
4c4b4cd2
PH
3858/* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3859 records in OBSTACKP. Do nothing if SYM is a duplicate. */
14f9c5c9
AS
3860
3861static void
76a01679
JB
3862add_defn_to_vec (struct obstack *obstackp,
3863 struct symbol *sym,
3864 struct block *block, struct symtab *symtab)
14f9c5c9
AS
3865{
3866 int i;
3867 size_t tmp;
4c4b4cd2 3868 struct ada_symbol_info *prevDefns = defns_collected (obstackp, 0);
14f9c5c9 3869
d2e4a39e 3870 if (SYMBOL_TYPE (sym) != NULL)
14f9c5c9 3871 CHECK_TYPEDEF (SYMBOL_TYPE (sym));
4c4b4cd2
PH
3872 for (i = num_defns_collected (obstackp) - 1; i >= 0; i -= 1)
3873 {
3874 if (lesseq_defined_than (sym, prevDefns[i].sym))
3875 return;
3876 else if (lesseq_defined_than (prevDefns[i].sym, sym))
3877 {
3878 prevDefns[i].sym = sym;
3879 prevDefns[i].block = block;
76a01679 3880 prevDefns[i].symtab = symtab;
4c4b4cd2 3881 return;
76a01679 3882 }
4c4b4cd2
PH
3883 }
3884
3885 {
3886 struct ada_symbol_info info;
3887
3888 info.sym = sym;
3889 info.block = block;
3890 info.symtab = symtab;
3891 obstack_grow (obstackp, &info, sizeof (struct ada_symbol_info));
3892 }
3893}
3894
3895/* Number of ada_symbol_info structures currently collected in
3896 current vector in *OBSTACKP. */
3897
76a01679
JB
3898static int
3899num_defns_collected (struct obstack *obstackp)
4c4b4cd2
PH
3900{
3901 return obstack_object_size (obstackp) / sizeof (struct ada_symbol_info);
3902}
3903
3904/* Vector of ada_symbol_info structures currently collected in current
3905 vector in *OBSTACKP. If FINISH, close off the vector and return
3906 its final address. */
3907
76a01679 3908static struct ada_symbol_info *
4c4b4cd2
PH
3909defns_collected (struct obstack *obstackp, int finish)
3910{
3911 if (finish)
3912 return obstack_finish (obstackp);
3913 else
3914 return (struct ada_symbol_info *) obstack_base (obstackp);
3915}
3916
96d887e8
PH
3917/* Look, in partial_symtab PST, for symbol NAME in given namespace.
3918 Check the global symbols if GLOBAL, the static symbols if not.
3919 Do wild-card match if WILD. */
4c4b4cd2 3920
96d887e8
PH
3921static struct partial_symbol *
3922ada_lookup_partial_symbol (struct partial_symtab *pst, const char *name,
3923 int global, domain_enum namespace, int wild)
4c4b4cd2 3924{
96d887e8
PH
3925 struct partial_symbol **start;
3926 int name_len = strlen (name);
3927 int length = (global ? pst->n_global_syms : pst->n_static_syms);
3928 int i;
4c4b4cd2 3929
96d887e8 3930 if (length == 0)
4c4b4cd2 3931 {
96d887e8 3932 return (NULL);
4c4b4cd2
PH
3933 }
3934
96d887e8
PH
3935 start = (global ?
3936 pst->objfile->global_psymbols.list + pst->globals_offset :
3937 pst->objfile->static_psymbols.list + pst->statics_offset);
4c4b4cd2 3938
96d887e8 3939 if (wild)
4c4b4cd2 3940 {
96d887e8
PH
3941 for (i = 0; i < length; i += 1)
3942 {
3943 struct partial_symbol *psym = start[i];
4c4b4cd2 3944
1265e4aa
JB
3945 if (SYMBOL_DOMAIN (psym) == namespace
3946 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (psym)))
96d887e8
PH
3947 return psym;
3948 }
3949 return NULL;
4c4b4cd2 3950 }
96d887e8
PH
3951 else
3952 {
3953 if (global)
3954 {
3955 int U;
3956 i = 0;
3957 U = length - 1;
3958 while (U - i > 4)
3959 {
3960 int M = (U + i) >> 1;
3961 struct partial_symbol *psym = start[M];
3962 if (SYMBOL_LINKAGE_NAME (psym)[0] < name[0])
3963 i = M + 1;
3964 else if (SYMBOL_LINKAGE_NAME (psym)[0] > name[0])
3965 U = M - 1;
3966 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), name) < 0)
3967 i = M + 1;
3968 else
3969 U = M;
3970 }
3971 }
3972 else
3973 i = 0;
4c4b4cd2 3974
96d887e8
PH
3975 while (i < length)
3976 {
3977 struct partial_symbol *psym = start[i];
4c4b4cd2 3978
96d887e8
PH
3979 if (SYMBOL_DOMAIN (psym) == namespace)
3980 {
3981 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym), name_len);
4c4b4cd2 3982
96d887e8
PH
3983 if (cmp < 0)
3984 {
3985 if (global)
3986 break;
3987 }
3988 else if (cmp == 0
3989 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
76a01679 3990 + name_len))
96d887e8
PH
3991 return psym;
3992 }
3993 i += 1;
3994 }
4c4b4cd2 3995
96d887e8
PH
3996 if (global)
3997 {
3998 int U;
3999 i = 0;
4000 U = length - 1;
4001 while (U - i > 4)
4002 {
4003 int M = (U + i) >> 1;
4004 struct partial_symbol *psym = start[M];
4005 if (SYMBOL_LINKAGE_NAME (psym)[0] < '_')
4006 i = M + 1;
4007 else if (SYMBOL_LINKAGE_NAME (psym)[0] > '_')
4008 U = M - 1;
4009 else if (strcmp (SYMBOL_LINKAGE_NAME (psym), "_ada_") < 0)
4010 i = M + 1;
4011 else
4012 U = M;
4013 }
4014 }
4015 else
4016 i = 0;
4c4b4cd2 4017
96d887e8
PH
4018 while (i < length)
4019 {
4020 struct partial_symbol *psym = start[i];
4c4b4cd2 4021
96d887e8
PH
4022 if (SYMBOL_DOMAIN (psym) == namespace)
4023 {
4024 int cmp;
4c4b4cd2 4025
96d887e8
PH
4026 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym)[0];
4027 if (cmp == 0)
4028 {
4029 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym), 5);
4030 if (cmp == 0)
4031 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (psym) + 5,
76a01679 4032 name_len);
96d887e8 4033 }
4c4b4cd2 4034
96d887e8
PH
4035 if (cmp < 0)
4036 {
4037 if (global)
4038 break;
4039 }
4040 else if (cmp == 0
4041 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym)
76a01679 4042 + name_len + 5))
96d887e8
PH
4043 return psym;
4044 }
4045 i += 1;
4046 }
4047 }
4048 return NULL;
4c4b4cd2
PH
4049}
4050
96d887e8 4051/* Find a symbol table containing symbol SYM or NULL if none. */
4c4b4cd2 4052
96d887e8
PH
4053static struct symtab *
4054symtab_for_sym (struct symbol *sym)
4c4b4cd2 4055{
96d887e8
PH
4056 struct symtab *s;
4057 struct objfile *objfile;
4058 struct block *b;
4059 struct symbol *tmp_sym;
4060 struct dict_iterator iter;
4061 int j;
4c4b4cd2 4062
96d887e8
PH
4063 ALL_SYMTABS (objfile, s)
4064 {
4065 switch (SYMBOL_CLASS (sym))
4066 {
4067 case LOC_CONST:
4068 case LOC_STATIC:
4069 case LOC_TYPEDEF:
4070 case LOC_REGISTER:
4071 case LOC_LABEL:
4072 case LOC_BLOCK:
4073 case LOC_CONST_BYTES:
76a01679
JB
4074 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
4075 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4076 return s;
4077 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
4078 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4079 return s;
96d887e8
PH
4080 break;
4081 default:
4082 break;
4083 }
4084 switch (SYMBOL_CLASS (sym))
4085 {
4086 case LOC_REGISTER:
4087 case LOC_ARG:
4088 case LOC_REF_ARG:
4089 case LOC_REGPARM:
4090 case LOC_REGPARM_ADDR:
4091 case LOC_LOCAL:
4092 case LOC_TYPEDEF:
4093 case LOC_LOCAL_ARG:
4094 case LOC_BASEREG:
4095 case LOC_BASEREG_ARG:
4096 case LOC_COMPUTED:
4097 case LOC_COMPUTED_ARG:
76a01679
JB
4098 for (j = FIRST_LOCAL_BLOCK;
4099 j < BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s)); j += 1)
4100 {
4101 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), j);
4102 ALL_BLOCK_SYMBOLS (b, iter, tmp_sym) if (sym == tmp_sym)
4103 return s;
4104 }
4105 break;
96d887e8
PH
4106 default:
4107 break;
4108 }
4109 }
4110 return NULL;
4c4b4cd2
PH
4111}
4112
96d887e8
PH
4113/* Return a minimal symbol matching NAME according to Ada decoding
4114 rules. Returns NULL if there is no such minimal symbol. Names
4115 prefixed with "standard__" are handled specially: "standard__" is
4116 first stripped off, and only static and global symbols are searched. */
4c4b4cd2 4117
96d887e8
PH
4118struct minimal_symbol *
4119ada_lookup_simple_minsym (const char *name)
4c4b4cd2 4120{
4c4b4cd2 4121 struct objfile *objfile;
96d887e8
PH
4122 struct minimal_symbol *msymbol;
4123 int wild_match;
4c4b4cd2 4124
96d887e8 4125 if (strncmp (name, "standard__", sizeof ("standard__") - 1) == 0)
4c4b4cd2 4126 {
96d887e8 4127 name += sizeof ("standard__") - 1;
4c4b4cd2 4128 wild_match = 0;
4c4b4cd2
PH
4129 }
4130 else
96d887e8 4131 wild_match = (strstr (name, "__") == NULL);
4c4b4cd2 4132
96d887e8
PH
4133 ALL_MSYMBOLS (objfile, msymbol)
4134 {
4135 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match)
4136 && MSYMBOL_TYPE (msymbol) != mst_solib_trampoline)
4137 return msymbol;
4138 }
4c4b4cd2 4139
96d887e8
PH
4140 return NULL;
4141}
4c4b4cd2 4142
96d887e8
PH
4143/* Return up minimal symbol for NAME, folded and encoded according to
4144 Ada conventions, or NULL if none. The last two arguments are ignored. */
4c4b4cd2 4145
96d887e8
PH
4146static struct minimal_symbol *
4147ada_lookup_minimal_symbol (const char *name, const char *sfile,
76a01679 4148 struct objfile *objf)
96d887e8
PH
4149{
4150 return ada_lookup_simple_minsym (ada_encode (name));
4151}
4c4b4cd2 4152
96d887e8
PH
4153/* For all subprograms that statically enclose the subprogram of the
4154 selected frame, add symbols matching identifier NAME in DOMAIN
4155 and their blocks to the list of data in OBSTACKP, as for
4156 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4157 wildcard prefix. */
4c4b4cd2 4158
96d887e8
PH
4159static void
4160add_symbols_from_enclosing_procs (struct obstack *obstackp,
76a01679 4161 const char *name, domain_enum namespace,
96d887e8
PH
4162 int wild_match)
4163{
4164#ifdef HAVE_ADD_SYMBOLS_FROM_ENCLOSING_PROCS
4165 /* Use a heuristic to find the frames of enclosing subprograms: treat the
4166 pointer-sized value at location 0 from the local-variable base of a
4167 frame as a static link, and then search up the call stack for a
4168 frame with that same local-variable base. */
4169 static struct symbol static_link_sym;
4170 static struct symbol *static_link;
4171 struct value *target_link_val;
4c4b4cd2 4172
96d887e8
PH
4173 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
4174 struct frame_info *frame;
4c4b4cd2 4175
76a01679 4176 if (!target_has_stack)
96d887e8 4177 return;
4c4b4cd2 4178
96d887e8 4179 if (static_link == NULL)
4c4b4cd2 4180 {
96d887e8
PH
4181 /* Initialize the local variable symbol that stands for the
4182 static link (when there is one). */
4183 static_link = &static_link_sym;
4184 SYMBOL_LINKAGE_NAME (static_link) = "";
4185 SYMBOL_LANGUAGE (static_link) = language_unknown;
4186 SYMBOL_CLASS (static_link) = LOC_LOCAL;
4187 SYMBOL_DOMAIN (static_link) = VAR_DOMAIN;
4188 SYMBOL_TYPE (static_link) = lookup_pointer_type (builtin_type_void);
4189 SYMBOL_VALUE (static_link) =
4190 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link));
14f9c5c9
AS
4191 }
4192
96d887e8 4193 frame = get_selected_frame ();
76a01679 4194 if (frame == NULL || inside_main_func (get_frame_address_in_block (frame)))
96d887e8 4195 return;
14f9c5c9 4196
96d887e8
PH
4197 target_link_val = read_var_value (static_link, frame);
4198 while (target_link_val != NULL
76a01679
JB
4199 && num_defns_collected (obstackp) == 0
4200 && frame_relative_level (frame) <= MAX_ENCLOSING_FRAME_LEVELS)
96d887e8
PH
4201 {
4202 CORE_ADDR target_link = value_as_address (target_link_val);
4c4b4cd2 4203
96d887e8
PH
4204 frame = get_prev_frame (frame);
4205 if (frame == NULL)
76a01679 4206 break;
14f9c5c9 4207
96d887e8 4208 if (get_frame_locals_address (frame) == target_link)
76a01679
JB
4209 {
4210 struct block *block;
4211
4212 QUIT;
4213
4214 block = get_frame_block (frame, 0);
4215 while (block != NULL && block_function (block) != NULL
4216 && num_defns_collected (obstackp) == 0)
4217 {
4218 QUIT;
14f9c5c9 4219
76a01679
JB
4220 ada_add_block_symbols (obstackp, block, name, namespace,
4221 NULL, NULL, wild_match);
14f9c5c9 4222
76a01679
JB
4223 block = BLOCK_SUPERBLOCK (block);
4224 }
4225 }
14f9c5c9 4226 }
d2e4a39e 4227
96d887e8
PH
4228 do_cleanups (old_chain);
4229#endif
4230}
14f9c5c9 4231
96d887e8 4232/* FIXME: The next two routines belong in symtab.c */
14f9c5c9 4233
76a01679
JB
4234static void
4235restore_language (void *lang)
96d887e8
PH
4236{
4237 set_language ((enum language) lang);
4238}
4c4b4cd2 4239
96d887e8
PH
4240/* As for lookup_symbol, but performed as if the current language
4241 were LANG. */
4c4b4cd2 4242
96d887e8
PH
4243struct symbol *
4244lookup_symbol_in_language (const char *name, const struct block *block,
76a01679
JB
4245 domain_enum domain, enum language lang,
4246 int *is_a_field_of_this, struct symtab **symtab)
96d887e8 4247{
76a01679
JB
4248 struct cleanup *old_chain
4249 = make_cleanup (restore_language, (void *) current_language->la_language);
96d887e8
PH
4250 struct symbol *result;
4251 set_language (lang);
4252 result = lookup_symbol (name, block, domain, is_a_field_of_this, symtab);
4253 do_cleanups (old_chain);
4254 return result;
4255}
14f9c5c9 4256
96d887e8
PH
4257/* True if TYPE is definitely an artificial type supplied to a symbol
4258 for which no debugging information was given in the symbol file. */
14f9c5c9 4259
96d887e8
PH
4260static int
4261is_nondebugging_type (struct type *type)
4262{
4263 char *name = ada_type_name (type);
4264 return (name != NULL && strcmp (name, "<variable, no debug info>") == 0);
4265}
4c4b4cd2 4266
96d887e8
PH
4267/* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4268 duplicate other symbols in the list (The only case I know of where
4269 this happens is when object files containing stabs-in-ecoff are
4270 linked with files containing ordinary ecoff debugging symbols (or no
4271 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4272 Returns the number of items in the modified list. */
4c4b4cd2 4273
96d887e8
PH
4274static int
4275remove_extra_symbols (struct ada_symbol_info *syms, int nsyms)
4276{
4277 int i, j;
4c4b4cd2 4278
96d887e8
PH
4279 i = 0;
4280 while (i < nsyms)
4281 {
4282 if (SYMBOL_LINKAGE_NAME (syms[i].sym) != NULL
4283 && SYMBOL_CLASS (syms[i].sym) == LOC_STATIC
4284 && is_nondebugging_type (SYMBOL_TYPE (syms[i].sym)))
4285 {
4286 for (j = 0; j < nsyms; j += 1)
4287 {
4288 if (i != j
4289 && SYMBOL_LINKAGE_NAME (syms[j].sym) != NULL
4290 && strcmp (SYMBOL_LINKAGE_NAME (syms[i].sym),
76a01679 4291 SYMBOL_LINKAGE_NAME (syms[j].sym)) == 0
96d887e8
PH
4292 && SYMBOL_CLASS (syms[i].sym) == SYMBOL_CLASS (syms[j].sym)
4293 && SYMBOL_VALUE_ADDRESS (syms[i].sym)
4294 == SYMBOL_VALUE_ADDRESS (syms[j].sym))
4c4b4cd2 4295 {
96d887e8
PH
4296 int k;
4297 for (k = i + 1; k < nsyms; k += 1)
76a01679 4298 syms[k - 1] = syms[k];
96d887e8
PH
4299 nsyms -= 1;
4300 goto NextSymbol;
4c4b4cd2 4301 }
4c4b4cd2 4302 }
4c4b4cd2 4303 }
96d887e8
PH
4304 i += 1;
4305 NextSymbol:
4306 ;
14f9c5c9 4307 }
96d887e8 4308 return nsyms;
14f9c5c9
AS
4309}
4310
96d887e8
PH
4311/* Given a type that corresponds to a renaming entity, use the type name
4312 to extract the scope (package name or function name, fully qualified,
4313 and following the GNAT encoding convention) where this renaming has been
4314 defined. The string returned needs to be deallocated after use. */
4c4b4cd2 4315
96d887e8
PH
4316static char *
4317xget_renaming_scope (struct type *renaming_type)
14f9c5c9 4318{
96d887e8
PH
4319 /* The renaming types adhere to the following convention:
4320 <scope>__<rename>___<XR extension>.
4321 So, to extract the scope, we search for the "___XR" extension,
4322 and then backtrack until we find the first "__". */
76a01679 4323
96d887e8
PH
4324 const char *name = type_name_no_tag (renaming_type);
4325 char *suffix = strstr (name, "___XR");
4326 char *last;
4327 int scope_len;
4328 char *scope;
14f9c5c9 4329
96d887e8
PH
4330 /* Now, backtrack a bit until we find the first "__". Start looking
4331 at suffix - 3, as the <rename> part is at least one character long. */
14f9c5c9 4332
96d887e8
PH
4333 for (last = suffix - 3; last > name; last--)
4334 if (last[0] == '_' && last[1] == '_')
4335 break;
76a01679 4336
96d887e8 4337 /* Make a copy of scope and return it. */
14f9c5c9 4338
96d887e8
PH
4339 scope_len = last - name;
4340 scope = (char *) xmalloc ((scope_len + 1) * sizeof (char));
14f9c5c9 4341
96d887e8
PH
4342 strncpy (scope, name, scope_len);
4343 scope[scope_len] = '\0';
4c4b4cd2 4344
96d887e8 4345 return scope;
4c4b4cd2
PH
4346}
4347
96d887e8 4348/* Return nonzero if NAME corresponds to a package name. */
4c4b4cd2 4349
96d887e8
PH
4350static int
4351is_package_name (const char *name)
4c4b4cd2 4352{
96d887e8
PH
4353 /* Here, We take advantage of the fact that no symbols are generated
4354 for packages, while symbols are generated for each function.
4355 So the condition for NAME represent a package becomes equivalent
4356 to NAME not existing in our list of symbols. There is only one
4357 small complication with library-level functions (see below). */
4c4b4cd2 4358
96d887e8 4359 char *fun_name;
76a01679 4360
96d887e8
PH
4361 /* If it is a function that has not been defined at library level,
4362 then we should be able to look it up in the symbols. */
4363 if (standard_lookup (name, NULL, VAR_DOMAIN) != NULL)
4364 return 0;
14f9c5c9 4365
96d887e8
PH
4366 /* Library-level function names start with "_ada_". See if function
4367 "_ada_" followed by NAME can be found. */
14f9c5c9 4368
96d887e8
PH
4369 /* Do a quick check that NAME does not contain "__", since library-level
4370 functions names can not contain "__" in them. */
4371 if (strstr (name, "__") != NULL)
4372 return 0;
4c4b4cd2 4373
96d887e8
PH
4374 fun_name = (char *) alloca (strlen (name) + 5 + 1);
4375 xasprintf (&fun_name, "_ada_%s", name);
14f9c5c9 4376
96d887e8
PH
4377 return (standard_lookup (fun_name, NULL, VAR_DOMAIN) == NULL);
4378}
14f9c5c9 4379
96d887e8
PH
4380/* Return nonzero if SYM corresponds to a renaming entity that is
4381 visible from FUNCTION_NAME. */
14f9c5c9 4382
96d887e8
PH
4383static int
4384renaming_is_visible (const struct symbol *sym, char *function_name)
4385{
4386 char *scope = xget_renaming_scope (SYMBOL_TYPE (sym));
d2e4a39e 4387
96d887e8 4388 make_cleanup (xfree, scope);
14f9c5c9 4389
96d887e8
PH
4390 /* If the rename has been defined in a package, then it is visible. */
4391 if (is_package_name (scope))
4392 return 1;
14f9c5c9 4393
96d887e8
PH
4394 /* Check that the rename is in the current function scope by checking
4395 that its name starts with SCOPE. */
76a01679 4396
96d887e8
PH
4397 /* If the function name starts with "_ada_", it means that it is
4398 a library-level function. Strip this prefix before doing the
4399 comparison, as the encoding for the renaming does not contain
4400 this prefix. */
4401 if (strncmp (function_name, "_ada_", 5) == 0)
4402 function_name += 5;
f26caa11 4403
96d887e8 4404 return (strncmp (function_name, scope, strlen (scope)) == 0);
f26caa11
PH
4405}
4406
96d887e8
PH
4407/* Iterates over the SYMS list and remove any entry that corresponds to
4408 a renaming entity that is not visible from the function associated
4409 with CURRENT_BLOCK.
4410
4411 Rationale:
4412 GNAT emits a type following a specified encoding for each renaming
4413 entity. Unfortunately, STABS currently does not support the definition
4414 of types that are local to a given lexical block, so all renamings types
4415 are emitted at library level. As a consequence, if an application
4416 contains two renaming entities using the same name, and a user tries to
4417 print the value of one of these entities, the result of the ada symbol
4418 lookup will also contain the wrong renaming type.
f26caa11 4419
96d887e8
PH
4420 This function partially covers for this limitation by attempting to
4421 remove from the SYMS list renaming symbols that should be visible
4422 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4423 method with the current information available. The implementation
4424 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4425
4426 - When the user tries to print a rename in a function while there
4427 is another rename entity defined in a package: Normally, the
4428 rename in the function has precedence over the rename in the
4429 package, so the latter should be removed from the list. This is
4430 currently not the case.
4431
4432 - This function will incorrectly remove valid renames if
4433 the CURRENT_BLOCK corresponds to a function which symbol name
4434 has been changed by an "Export" pragma. As a consequence,
4435 the user will be unable to print such rename entities. */
4c4b4cd2 4436
14f9c5c9 4437static int
96d887e8 4438remove_out_of_scope_renamings (struct ada_symbol_info *syms,
76a01679 4439 int nsyms, struct block *current_block)
4c4b4cd2
PH
4440{
4441 struct symbol *current_function;
4442 char *current_function_name;
4443 int i;
4444
4445 /* Extract the function name associated to CURRENT_BLOCK.
4446 Abort if unable to do so. */
76a01679 4447
4c4b4cd2
PH
4448 if (current_block == NULL)
4449 return nsyms;
76a01679 4450
4c4b4cd2
PH
4451 current_function = block_function (current_block);
4452 if (current_function == NULL)
4453 return nsyms;
4454
4455 current_function_name = SYMBOL_LINKAGE_NAME (current_function);
4456 if (current_function_name == NULL)
4457 return nsyms;
4458
4459 /* Check each of the symbols, and remove it from the list if it is
4460 a type corresponding to a renaming that is out of the scope of
4461 the current block. */
4462
4463 i = 0;
4464 while (i < nsyms)
4465 {
4466 if (ada_is_object_renaming (syms[i].sym)
4467 && !renaming_is_visible (syms[i].sym, current_function_name))
4468 {
4469 int j;
4470 for (j = i + 1; j < nsyms; j++)
76a01679 4471 syms[j - 1] = syms[j];
4c4b4cd2
PH
4472 nsyms -= 1;
4473 }
4474 else
4475 i += 1;
4476 }
4477
4478 return nsyms;
4479}
4480
4481/* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4482 scope and in global scopes, returning the number of matches. Sets
4483 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4484 indicating the symbols found and the blocks and symbol tables (if
4485 any) in which they were found. This vector are transient---good only to
4486 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4487 symbol match within the nest of blocks whose innermost member is BLOCK0,
4488 is the one match returned (no other matches in that or
4489 enclosing blocks is returned). If there are any matches in or
4490 surrounding BLOCK0, then these alone are returned. Otherwise, the
4491 search extends to global and file-scope (static) symbol tables.
4492 Names prefixed with "standard__" are handled specially: "standard__"
4493 is first stripped off, and only static and global symbols are searched. */
14f9c5c9
AS
4494
4495int
4c4b4cd2 4496ada_lookup_symbol_list (const char *name0, const struct block *block0,
76a01679
JB
4497 domain_enum namespace,
4498 struct ada_symbol_info **results)
14f9c5c9
AS
4499{
4500 struct symbol *sym;
4501 struct symtab *s;
4502 struct partial_symtab *ps;
4503 struct blockvector *bv;
4504 struct objfile *objfile;
14f9c5c9 4505 struct block *block;
4c4b4cd2 4506 const char *name;
14f9c5c9 4507 struct minimal_symbol *msymbol;
4c4b4cd2 4508 int wild_match;
14f9c5c9 4509 int cacheIfUnique;
4c4b4cd2
PH
4510 int block_depth;
4511 int ndefns;
14f9c5c9 4512
4c4b4cd2
PH
4513 obstack_free (&symbol_list_obstack, NULL);
4514 obstack_init (&symbol_list_obstack);
14f9c5c9 4515
14f9c5c9
AS
4516 cacheIfUnique = 0;
4517
4518 /* Search specified block and its superiors. */
4519
4c4b4cd2
PH
4520 wild_match = (strstr (name0, "__") == NULL);
4521 name = name0;
76a01679
JB
4522 block = (struct block *) block0; /* FIXME: No cast ought to be
4523 needed, but adding const will
4524 have a cascade effect. */
4c4b4cd2
PH
4525 if (strncmp (name0, "standard__", sizeof ("standard__") - 1) == 0)
4526 {
4527 wild_match = 0;
4528 block = NULL;
4529 name = name0 + sizeof ("standard__") - 1;
4530 }
4531
4532 block_depth = 0;
14f9c5c9
AS
4533 while (block != NULL)
4534 {
4c4b4cd2 4535 block_depth += 1;
76a01679
JB
4536 ada_add_block_symbols (&symbol_list_obstack, block, name,
4537 namespace, NULL, NULL, wild_match);
14f9c5c9 4538
4c4b4cd2
PH
4539 /* If we found a non-function match, assume that's the one. */
4540 if (is_nonfunction (defns_collected (&symbol_list_obstack, 0),
76a01679 4541 num_defns_collected (&symbol_list_obstack)))
4c4b4cd2 4542 goto done;
14f9c5c9
AS
4543
4544 block = BLOCK_SUPERBLOCK (block);
4545 }
4546
4c4b4cd2
PH
4547 /* If no luck so far, try to find NAME as a local symbol in some lexically
4548 enclosing subprogram. */
4549 if (num_defns_collected (&symbol_list_obstack) == 0 && block_depth > 2)
4550 add_symbols_from_enclosing_procs (&symbol_list_obstack,
76a01679 4551 name, namespace, wild_match);
4c4b4cd2
PH
4552
4553 /* If we found ANY matches among non-global symbols, we're done. */
14f9c5c9 4554
4c4b4cd2 4555 if (num_defns_collected (&symbol_list_obstack) > 0)
14f9c5c9 4556 goto done;
d2e4a39e 4557
14f9c5c9 4558 cacheIfUnique = 1;
4c4b4cd2
PH
4559 if (lookup_cached_symbol (name0, namespace, &sym, &block, &s))
4560 {
4561 if (sym != NULL)
4562 add_defn_to_vec (&symbol_list_obstack, sym, block, s);
4563 goto done;
4564 }
14f9c5c9
AS
4565
4566 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4c4b4cd2 4567 tables, and psymtab's. */
14f9c5c9
AS
4568
4569 ALL_SYMTABS (objfile, s)
d2e4a39e
AS
4570 {
4571 QUIT;
4572 if (!s->primary)
4573 continue;
4574 bv = BLOCKVECTOR (s);
4575 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
76a01679
JB
4576 ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
4577 objfile, s, wild_match);
d2e4a39e 4578 }
14f9c5c9 4579
4c4b4cd2 4580 if (namespace == VAR_DOMAIN)
14f9c5c9
AS
4581 {
4582 ALL_MSYMBOLS (objfile, msymbol)
d2e4a39e 4583 {
4c4b4cd2
PH
4584 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol), name, wild_match))
4585 {
4586 switch (MSYMBOL_TYPE (msymbol))
4587 {
4588 case mst_solib_trampoline:
4589 break;
4590 default:
4591 s = find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol));
4592 if (s != NULL)
4593 {
4594 int ndefns0 = num_defns_collected (&symbol_list_obstack);
4595 QUIT;
4596 bv = BLOCKVECTOR (s);
4597 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4598 ada_add_block_symbols (&symbol_list_obstack, block,
4599 SYMBOL_LINKAGE_NAME (msymbol),
4600 namespace, objfile, s, wild_match);
76a01679 4601
4c4b4cd2
PH
4602 if (num_defns_collected (&symbol_list_obstack) == ndefns0)
4603 {
4604 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
4605 ada_add_block_symbols (&symbol_list_obstack, block,
4606 SYMBOL_LINKAGE_NAME (msymbol),
4607 namespace, objfile, s,
4608 wild_match);
4609 }
4610 }
4611 }
4612 }
d2e4a39e 4613 }
14f9c5c9 4614 }
d2e4a39e 4615
14f9c5c9 4616 ALL_PSYMTABS (objfile, ps)
d2e4a39e
AS
4617 {
4618 QUIT;
4619 if (!ps->readin
4c4b4cd2 4620 && ada_lookup_partial_symbol (ps, name, 1, namespace, wild_match))
d2e4a39e 4621 {
4c4b4cd2
PH
4622 s = PSYMTAB_TO_SYMTAB (ps);
4623 if (!s->primary)
4624 continue;
4625 bv = BLOCKVECTOR (s);
4626 block = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4627 ada_add_block_symbols (&symbol_list_obstack, block, name,
76a01679 4628 namespace, objfile, s, wild_match);
d2e4a39e
AS
4629 }
4630 }
4631
4c4b4cd2 4632 /* Now add symbols from all per-file blocks if we've gotten no hits
14f9c5c9 4633 (Not strictly correct, but perhaps better than an error).
4c4b4cd2 4634 Do the symtabs first, then check the psymtabs. */
d2e4a39e 4635
4c4b4cd2 4636 if (num_defns_collected (&symbol_list_obstack) == 0)
14f9c5c9
AS
4637 {
4638
4639 ALL_SYMTABS (objfile, s)
d2e4a39e 4640 {
4c4b4cd2
PH
4641 QUIT;
4642 if (!s->primary)
4643 continue;
4644 bv = BLOCKVECTOR (s);
4645 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
76a01679
JB
4646 ada_add_block_symbols (&symbol_list_obstack, block, name, namespace,
4647 objfile, s, wild_match);
d2e4a39e
AS
4648 }
4649
14f9c5c9 4650 ALL_PSYMTABS (objfile, ps)
d2e4a39e 4651 {
4c4b4cd2
PH
4652 QUIT;
4653 if (!ps->readin
4654 && ada_lookup_partial_symbol (ps, name, 0, namespace, wild_match))
4655 {
4656 s = PSYMTAB_TO_SYMTAB (ps);
4657 bv = BLOCKVECTOR (s);
4658 if (!s->primary)
4659 continue;
4660 block = BLOCKVECTOR_BLOCK (bv, STATIC_BLOCK);
76a01679
JB
4661 ada_add_block_symbols (&symbol_list_obstack, block, name,
4662 namespace, objfile, s, wild_match);
4c4b4cd2 4663 }
d2e4a39e
AS
4664 }
4665 }
14f9c5c9 4666
4c4b4cd2
PH
4667done:
4668 ndefns = num_defns_collected (&symbol_list_obstack);
4669 *results = defns_collected (&symbol_list_obstack, 1);
4670
4671 ndefns = remove_extra_symbols (*results, ndefns);
4672
d2e4a39e 4673 if (ndefns == 0)
4c4b4cd2 4674 cache_symbol (name0, namespace, NULL, NULL, NULL);
14f9c5c9 4675
4c4b4cd2 4676 if (ndefns == 1 && cacheIfUnique)
76a01679
JB
4677 cache_symbol (name0, namespace, (*results)[0].sym, (*results)[0].block,
4678 (*results)[0].symtab);
14f9c5c9 4679
4c4b4cd2
PH
4680 ndefns = remove_out_of_scope_renamings (*results, ndefns,
4681 (struct block *) block0);
14f9c5c9 4682
14f9c5c9
AS
4683 return ndefns;
4684}
4685
4c4b4cd2
PH
4686/* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4687 scope and in global scopes, or NULL if none. NAME is folded and
4688 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4689 but is disambiguated by user query if needed. *IS_A_FIELD_OF_THIS is
4690 set to 0 and *SYMTAB is set to the symbol table in which the symbol
4691 was found (in both cases, these assignments occur only if the
4692 pointers are non-null). */
4693
14f9c5c9 4694
d2e4a39e 4695struct symbol *
4c4b4cd2
PH
4696ada_lookup_symbol (const char *name, const struct block *block0,
4697 domain_enum namespace, int *is_a_field_of_this,
76a01679 4698 struct symtab **symtab)
14f9c5c9 4699{
4c4b4cd2 4700 struct ada_symbol_info *candidates;
14f9c5c9
AS
4701 int n_candidates;
4702
4c4b4cd2
PH
4703 n_candidates = ada_lookup_symbol_list (ada_encode (ada_fold_name (name)),
4704 block0, namespace, &candidates);
14f9c5c9
AS
4705
4706 if (n_candidates == 0)
4707 return NULL;
4708 else if (n_candidates != 1)
4c4b4cd2
PH
4709 user_select_syms (candidates, n_candidates, 1);
4710
4711 if (is_a_field_of_this != NULL)
4712 *is_a_field_of_this = 0;
4713
76a01679 4714 if (symtab != NULL)
4c4b4cd2
PH
4715 {
4716 *symtab = candidates[0].symtab;
76a01679
JB
4717 if (*symtab == NULL && candidates[0].block != NULL)
4718 {
4719 struct objfile *objfile;
4720 struct symtab *s;
4721 struct block *b;
4722 struct blockvector *bv;
4723
4724 /* Search the list of symtabs for one which contains the
4725 address of the start of this block. */
4726 ALL_SYMTABS (objfile, s)
4727 {
4728 bv = BLOCKVECTOR (s);
4729 b = BLOCKVECTOR_BLOCK (bv, GLOBAL_BLOCK);
4730 if (BLOCK_START (b) <= BLOCK_START (candidates[0].block)
4731 && BLOCK_END (b) > BLOCK_START (candidates[0].block))
4732 {
4733 *symtab = s;
4734 return fixup_symbol_section (candidates[0].sym, objfile);
4735 }
4736 return fixup_symbol_section (candidates[0].sym, NULL);
4737 }
4738 }
4739 }
4c4b4cd2
PH
4740 return candidates[0].sym;
4741}
14f9c5c9 4742
4c4b4cd2
PH
4743static struct symbol *
4744ada_lookup_symbol_nonlocal (const char *name,
76a01679
JB
4745 const char *linkage_name,
4746 const struct block *block,
4747 const domain_enum domain, struct symtab **symtab)
4c4b4cd2
PH
4748{
4749 if (linkage_name == NULL)
4750 linkage_name = name;
76a01679
JB
4751 return ada_lookup_symbol (linkage_name, block_static_block (block), domain,
4752 NULL, symtab);
14f9c5c9
AS
4753}
4754
4755
4c4b4cd2
PH
4756/* True iff STR is a possible encoded suffix of a normal Ada name
4757 that is to be ignored for matching purposes. Suffixes of parallel
4758 names (e.g., XVE) are not included here. Currently, the possible suffixes
4759 are given by either of the regular expression:
4760
4761 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such as Linux]
4762 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4763 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(LJM|X([FDBUP].*|R[^T]?)))?$
14f9c5c9 4764 */
4c4b4cd2 4765
14f9c5c9 4766static int
d2e4a39e 4767is_name_suffix (const char *str)
14f9c5c9
AS
4768{
4769 int k;
4c4b4cd2
PH
4770 const char *matching;
4771 const int len = strlen (str);
4772
4773 /* (__[0-9]+)?\.[0-9]+ */
4774 matching = str;
4775 if (len > 3 && str[0] == '_' && str[1] == '_' && isdigit (str[2]))
4776 {
4777 matching += 3;
4778 while (isdigit (matching[0]))
4779 matching += 1;
4780 if (matching[0] == '\0')
4781 return 1;
4782 }
4783
4784 if (matching[0] == '.')
4785 {
4786 matching += 1;
4787 while (isdigit (matching[0]))
4788 matching += 1;
4789 if (matching[0] == '\0')
4790 return 1;
4791 }
4792
4793 /* ___[0-9]+ */
4794 if (len > 3 && str[0] == '_' && str[1] == '_' && str[2] == '_')
4795 {
4796 matching = str + 3;
4797 while (isdigit (matching[0]))
4798 matching += 1;
4799 if (matching[0] == '\0')
4800 return 1;
4801 }
4802
4803 /* ??? We should not modify STR directly, as we are doing below. This
4804 is fine in this case, but may become problematic later if we find
4805 that this alternative did not work, and want to try matching
4806 another one from the begining of STR. Since we modified it, we
4807 won't be able to find the begining of the string anymore! */
14f9c5c9
AS
4808 if (str[0] == 'X')
4809 {
4810 str += 1;
d2e4a39e 4811 while (str[0] != '_' && str[0] != '\0')
4c4b4cd2
PH
4812 {
4813 if (str[0] != 'n' && str[0] != 'b')
4814 return 0;
4815 str += 1;
4816 }
14f9c5c9
AS
4817 }
4818 if (str[0] == '\000')
4819 return 1;
d2e4a39e 4820 if (str[0] == '_')
14f9c5c9
AS
4821 {
4822 if (str[1] != '_' || str[2] == '\000')
4c4b4cd2 4823 return 0;
d2e4a39e 4824 if (str[2] == '_')
4c4b4cd2
PH
4825 {
4826 if (strcmp (str + 3, "LJM") == 0)
4827 return 1;
4828 if (str[3] != 'X')
4829 return 0;
1265e4aa
JB
4830 if (str[4] == 'F' || str[4] == 'D' || str[4] == 'B'
4831 || str[4] == 'U' || str[4] == 'P')
4c4b4cd2
PH
4832 return 1;
4833 if (str[4] == 'R' && str[5] != 'T')
4834 return 1;
4835 return 0;
4836 }
4837 if (!isdigit (str[2]))
4838 return 0;
4839 for (k = 3; str[k] != '\0'; k += 1)
4840 if (!isdigit (str[k]) && str[k] != '_')
4841 return 0;
14f9c5c9
AS
4842 return 1;
4843 }
4c4b4cd2 4844 if (str[0] == '$' && isdigit (str[1]))
14f9c5c9 4845 {
4c4b4cd2
PH
4846 for (k = 2; str[k] != '\0'; k += 1)
4847 if (!isdigit (str[k]) && str[k] != '_')
4848 return 0;
14f9c5c9
AS
4849 return 1;
4850 }
4851 return 0;
4852}
d2e4a39e 4853
4c4b4cd2
PH
4854/* Return nonzero if the given string starts with a dot ('.')
4855 followed by zero or more digits.
4856
4857 Note: brobecker/2003-11-10: A forward declaration has not been
4858 added at the begining of this file yet, because this function
4859 is only used to work around a problem found during wild matching
4860 when trying to match minimal symbol names against symbol names
4861 obtained from dwarf-2 data. This function is therefore currently
4862 only used in wild_match() and is likely to be deleted when the
4863 problem in dwarf-2 is fixed. */
4864
4865static int
4866is_dot_digits_suffix (const char *str)
4867{
4868 if (str[0] != '.')
4869 return 0;
4870
4871 str++;
4872 while (isdigit (str[0]))
4873 str++;
4874 return (str[0] == '\0');
4875}
4876
4877/* True if NAME represents a name of the form A1.A2....An, n>=1 and
4878 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4879 informational suffixes of NAME (i.e., for which is_name_suffix is
4880 true). */
4881
14f9c5c9 4882static int
4c4b4cd2 4883wild_match (const char *patn0, int patn_len, const char *name0)
14f9c5c9
AS
4884{
4885 int name_len;
4c4b4cd2
PH
4886 char *name;
4887 char *patn;
4888
4889 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4890 stored in the symbol table for nested function names is sometimes
4891 different from the name of the associated entity stored in
4892 the dwarf-2 data: This is the case for nested subprograms, where
4893 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4894 while the symbol name from the dwarf-2 data does not.
4895
4896 Although the DWARF-2 standard documents that entity names stored
4897 in the dwarf-2 data should be identical to the name as seen in
4898 the source code, GNAT takes a different approach as we already use
4899 a special encoding mechanism to convey the information so that
4900 a C debugger can still use the information generated to debug
4901 Ada programs. A corollary is that the symbol names in the dwarf-2
4902 data should match the names found in the symbol table. I therefore
4903 consider this issue as a compiler defect.
76a01679 4904
4c4b4cd2
PH
4905 Until the compiler is properly fixed, we work-around the problem
4906 by ignoring such suffixes during the match. We do so by making
4907 a copy of PATN0 and NAME0, and then by stripping such a suffix
4908 if present. We then perform the match on the resulting strings. */
4909 {
4910 char *dot;
4911 name_len = strlen (name0);
4912
4913 name = (char *) alloca ((name_len + 1) * sizeof (char));
4914 strcpy (name, name0);
4915 dot = strrchr (name, '.');
4916 if (dot != NULL && is_dot_digits_suffix (dot))
4917 *dot = '\0';
4918
4919 patn = (char *) alloca ((patn_len + 1) * sizeof (char));
4920 strncpy (patn, patn0, patn_len);
4921 patn[patn_len] = '\0';
4922 dot = strrchr (patn, '.');
4923 if (dot != NULL && is_dot_digits_suffix (dot))
4924 {
4925 *dot = '\0';
4926 patn_len = dot - patn;
4927 }
4928 }
4929
4930 /* Now perform the wild match. */
14f9c5c9
AS
4931
4932 name_len = strlen (name);
4c4b4cd2
PH
4933 if (name_len >= patn_len + 5 && strncmp (name, "_ada_", 5) == 0
4934 && strncmp (patn, name + 5, patn_len) == 0
d2e4a39e 4935 && is_name_suffix (name + patn_len + 5))
14f9c5c9
AS
4936 return 1;
4937
d2e4a39e 4938 while (name_len >= patn_len)
14f9c5c9 4939 {
4c4b4cd2
PH
4940 if (strncmp (patn, name, patn_len) == 0
4941 && is_name_suffix (name + patn_len))
4942 return 1;
4943 do
4944 {
4945 name += 1;
4946 name_len -= 1;
4947 }
d2e4a39e 4948 while (name_len > 0
4c4b4cd2 4949 && name[0] != '.' && (name[0] != '_' || name[1] != '_'));
14f9c5c9 4950 if (name_len <= 0)
4c4b4cd2 4951 return 0;
14f9c5c9 4952 if (name[0] == '_')
4c4b4cd2
PH
4953 {
4954 if (!islower (name[2]))
4955 return 0;
4956 name += 2;
4957 name_len -= 2;
4958 }
14f9c5c9 4959 else
4c4b4cd2
PH
4960 {
4961 if (!islower (name[1]))
4962 return 0;
4963 name += 1;
4964 name_len -= 1;
4965 }
96d887e8
PH
4966 }
4967
4968 return 0;
4969}
4970
4971
4972/* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4973 vector *defn_symbols, updating the list of symbols in OBSTACKP
4974 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4975 OBJFILE is the section containing BLOCK.
4976 SYMTAB is recorded with each symbol added. */
4977
4978static void
4979ada_add_block_symbols (struct obstack *obstackp,
76a01679 4980 struct block *block, const char *name,
96d887e8
PH
4981 domain_enum domain, struct objfile *objfile,
4982 struct symtab *symtab, int wild)
4983{
4984 struct dict_iterator iter;
4985 int name_len = strlen (name);
4986 /* A matching argument symbol, if any. */
4987 struct symbol *arg_sym;
4988 /* Set true when we find a matching non-argument symbol. */
4989 int found_sym;
4990 struct symbol *sym;
4991
4992 arg_sym = NULL;
4993 found_sym = 0;
4994 if (wild)
4995 {
4996 struct symbol *sym;
4997 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679 4998 {
1265e4aa
JB
4999 if (SYMBOL_DOMAIN (sym) == domain
5000 && wild_match (name, name_len, SYMBOL_LINKAGE_NAME (sym)))
76a01679
JB
5001 {
5002 switch (SYMBOL_CLASS (sym))
5003 {
5004 case LOC_ARG:
5005 case LOC_LOCAL_ARG:
5006 case LOC_REF_ARG:
5007 case LOC_REGPARM:
5008 case LOC_REGPARM_ADDR:
5009 case LOC_BASEREG_ARG:
5010 case LOC_COMPUTED_ARG:
5011 arg_sym = sym;
5012 break;
5013 case LOC_UNRESOLVED:
5014 continue;
5015 default:
5016 found_sym = 1;
5017 add_defn_to_vec (obstackp,
5018 fixup_symbol_section (sym, objfile),
5019 block, symtab);
5020 break;
5021 }
5022 }
5023 }
96d887e8
PH
5024 }
5025 else
5026 {
5027 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679
JB
5028 {
5029 if (SYMBOL_DOMAIN (sym) == domain)
5030 {
5031 int cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym), name_len);
5032 if (cmp == 0
5033 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len))
5034 {
5035 switch (SYMBOL_CLASS (sym))
5036 {
5037 case LOC_ARG:
5038 case LOC_LOCAL_ARG:
5039 case LOC_REF_ARG:
5040 case LOC_REGPARM:
5041 case LOC_REGPARM_ADDR:
5042 case LOC_BASEREG_ARG:
5043 case LOC_COMPUTED_ARG:
5044 arg_sym = sym;
5045 break;
5046 case LOC_UNRESOLVED:
5047 break;
5048 default:
5049 found_sym = 1;
5050 add_defn_to_vec (obstackp,
5051 fixup_symbol_section (sym, objfile),
5052 block, symtab);
5053 break;
5054 }
5055 }
5056 }
5057 }
96d887e8
PH
5058 }
5059
5060 if (!found_sym && arg_sym != NULL)
5061 {
76a01679
JB
5062 add_defn_to_vec (obstackp,
5063 fixup_symbol_section (arg_sym, objfile),
5064 block, symtab);
96d887e8
PH
5065 }
5066
5067 if (!wild)
5068 {
5069 arg_sym = NULL;
5070 found_sym = 0;
5071
5072 ALL_BLOCK_SYMBOLS (block, iter, sym)
76a01679
JB
5073 {
5074 if (SYMBOL_DOMAIN (sym) == domain)
5075 {
5076 int cmp;
5077
5078 cmp = (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym)[0];
5079 if (cmp == 0)
5080 {
5081 cmp = strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym), 5);
5082 if (cmp == 0)
5083 cmp = strncmp (name, SYMBOL_LINKAGE_NAME (sym) + 5,
5084 name_len);
5085 }
5086
5087 if (cmp == 0
5088 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym) + name_len + 5))
5089 {
5090 switch (SYMBOL_CLASS (sym))
5091 {
5092 case LOC_ARG:
5093 case LOC_LOCAL_ARG:
5094 case LOC_REF_ARG:
5095 case LOC_REGPARM:
5096 case LOC_REGPARM_ADDR:
5097 case LOC_BASEREG_ARG:
5098 case LOC_COMPUTED_ARG:
5099 arg_sym = sym;
5100 break;
5101 case LOC_UNRESOLVED:
5102 break;
5103 default:
5104 found_sym = 1;
5105 add_defn_to_vec (obstackp,
5106 fixup_symbol_section (sym, objfile),
5107 block, symtab);
5108 break;
5109 }
5110 }
5111 }
5112 end_loop2:;
5113 }
96d887e8
PH
5114
5115 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5116 They aren't parameters, right? */
5117 if (!found_sym && arg_sym != NULL)
5118 {
5119 add_defn_to_vec (obstackp,
76a01679
JB
5120 fixup_symbol_section (arg_sym, objfile),
5121 block, symtab);
96d887e8
PH
5122 }
5123 }
5124}
5125\f
5126#ifdef GNAT_GDB
5127
76a01679 5128 /* Symbol Completion */
96d887e8
PH
5129
5130/* If SYM_NAME is a completion candidate for TEXT, return this symbol
5131 name in a form that's appropriate for the completion. The result
5132 does not need to be deallocated, but is only good until the next call.
5133
5134 TEXT_LEN is equal to the length of TEXT.
5135 Perform a wild match if WILD_MATCH is set.
5136 ENCODED should be set if TEXT represents the start of a symbol name
5137 in its encoded form. */
5138
5139static const char *
76a01679 5140symbol_completion_match (const char *sym_name,
96d887e8
PH
5141 const char *text, int text_len,
5142 int wild_match, int encoded)
5143{
5144 char *result;
5145 const int verbatim_match = (text[0] == '<');
5146 int match = 0;
5147
5148 if (verbatim_match)
5149 {
5150 /* Strip the leading angle bracket. */
5151 text = text + 1;
5152 text_len--;
5153 }
5154
5155 /* First, test against the fully qualified name of the symbol. */
5156
5157 if (strncmp (sym_name, text, text_len) == 0)
5158 match = 1;
5159
5160 if (match && !encoded)
5161 {
5162 /* One needed check before declaring a positive match is to verify
5163 that iff we are doing a verbatim match, the decoded version
5164 of the symbol name starts with '<'. Otherwise, this symbol name
5165 is not a suitable completion. */
5166 const char *sym_name_copy = sym_name;
5167 int has_angle_bracket;
76a01679 5168
96d887e8 5169 sym_name = ada_decode (sym_name);
76a01679 5170 has_angle_bracket = (sym_name[0] == '<');
96d887e8
PH
5171 match = (has_angle_bracket == verbatim_match);
5172 sym_name = sym_name_copy;
5173 }
5174
5175 if (match && !verbatim_match)
5176 {
5177 /* When doing non-verbatim match, another check that needs to
5178 be done is to verify that the potentially matching symbol name
5179 does not include capital letters, because the ada-mode would
5180 not be able to understand these symbol names without the
5181 angle bracket notation. */
5182 const char *tmp;
5183
5184 for (tmp = sym_name; *tmp != '\0' && !isupper (*tmp); tmp++);
5185 if (*tmp != '\0')
5186 match = 0;
5187 }
5188
5189 /* Second: Try wild matching... */
5190
5191 if (!match && wild_match)
5192 {
5193 /* Since we are doing wild matching, this means that TEXT
5194 may represent an unqualified symbol name. We therefore must
5195 also compare TEXT against the unqualified name of the symbol. */
5196 sym_name = ada_unqualified_name (ada_decode (sym_name));
5197
5198 if (strncmp (sym_name, text, text_len) == 0)
5199 match = 1;
5200 }
5201
5202 /* Finally: If we found a mach, prepare the result to return. */
5203
5204 if (!match)
5205 return NULL;
5206
5207 if (verbatim_match)
5208 sym_name = add_angle_brackets (sym_name);
5209
5210 if (!encoded)
5211 sym_name = ada_decode (sym_name);
5212
5213 return sym_name;
5214}
5215
5216/* A companion function to ada_make_symbol_completion_list().
5217 Check if SYM_NAME represents a symbol which name would be suitable
5218 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5219 it is appended at the end of the given string vector SV.
5220
5221 ORIG_TEXT is the string original string from the user command
5222 that needs to be completed. WORD is the entire command on which
5223 completion should be performed. These two parameters are used to
5224 determine which part of the symbol name should be added to the
5225 completion vector.
5226 if WILD_MATCH is set, then wild matching is performed.
5227 ENCODED should be set if TEXT represents a symbol name in its
5228 encoded formed (in which case the completion should also be
5229 encoded). */
76a01679 5230
96d887e8
PH
5231static void
5232symbol_completion_add (struct string_vector *sv,
5233 const char *sym_name,
5234 const char *text, int text_len,
5235 const char *orig_text, const char *word,
5236 int wild_match, int encoded)
5237{
5238 const char *match = symbol_completion_match (sym_name, text, text_len,
5239 wild_match, encoded);
5240 char *completion;
5241
5242 if (match == NULL)
5243 return;
5244
5245 /* We found a match, so add the appropriate completion to the given
5246 string vector. */
5247
5248 if (word == orig_text)
5249 {
5250 completion = xmalloc (strlen (match) + 5);
5251 strcpy (completion, match);
5252 }
5253 else if (word > orig_text)
5254 {
5255 /* Return some portion of sym_name. */
5256 completion = xmalloc (strlen (match) + 5);
5257 strcpy (completion, match + (word - orig_text));
5258 }
5259 else
5260 {
5261 /* Return some of ORIG_TEXT plus sym_name. */
5262 completion = xmalloc (strlen (match) + (orig_text - word) + 5);
5263 strncpy (completion, word, orig_text - word);
5264 completion[orig_text - word] = '\0';
5265 strcat (completion, match);
5266 }
5267
5268 string_vector_append (sv, completion);
5269}
5270
5271/* Return a list of possible symbol names completing TEXT0. The list
5272 is NULL terminated. WORD is the entire command on which completion
5273 is made. */
5274
5275char **
5276ada_make_symbol_completion_list (const char *text0, const char *word)
5277{
5278 /* Note: This function is almost a copy of make_symbol_completion_list(),
5279 except it has been adapted for Ada. It is somewhat of a shame to
5280 duplicate so much code, but we don't really have the infrastructure
5281 yet to develop a language-aware version of he symbol completer... */
5282 char *text;
5283 int text_len;
5284 int wild_match;
5285 int encoded;
5286 struct string_vector result = xnew_string_vector (128);
5287 struct symbol *sym;
5288 struct symtab *s;
5289 struct partial_symtab *ps;
5290 struct minimal_symbol *msymbol;
5291 struct objfile *objfile;
5292 struct block *b, *surrounding_static_block = 0;
5293 int i;
5294 struct dict_iterator iter;
5295
5296 if (text0[0] == '<')
5297 {
5298 text = xstrdup (text0);
5299 make_cleanup (xfree, text);
5300 text_len = strlen (text);
5301 wild_match = 0;
5302 encoded = 1;
5303 }
5304 else
5305 {
5306 text = xstrdup (ada_encode (text0));
5307 make_cleanup (xfree, text);
5308 text_len = strlen (text);
5309 for (i = 0; i < text_len; i++)
5310 text[i] = tolower (text[i]);
5311
5312 /* FIXME: brobecker/2003-09-17: When we get rid of ADA_RETAIN_DOTS,
5313 we can restrict the wild_match check to searching "__" only. */
5314 wild_match = (strstr (text0, "__") == NULL
5315 && strchr (text0, '.') == NULL);
5316 encoded = (strstr (text0, "__") != NULL);
5317 }
5318
5319 /* First, look at the partial symtab symbols. */
5320 ALL_PSYMTABS (objfile, ps)
76a01679
JB
5321 {
5322 struct partial_symbol **psym;
96d887e8 5323
76a01679
JB
5324 /* If the psymtab's been read in we'll get it when we search
5325 through the blockvector. */
5326 if (ps->readin)
5327 continue;
96d887e8 5328
76a01679
JB
5329 for (psym = objfile->global_psymbols.list + ps->globals_offset;
5330 psym < (objfile->global_psymbols.list + ps->globals_offset
5331 + ps->n_global_syms); psym++)
5332 {
5333 QUIT;
5334 symbol_completion_add (&result, SYMBOL_LINKAGE_NAME (*psym),
5335 text, text_len, text0, word,
5336 wild_match, encoded);
5337 }
96d887e8 5338
76a01679
JB
5339 for (psym = objfile->static_psymbols.list + ps->statics_offset;
5340 psym < (objfile->static_psymbols.list + ps->statics_offset
5341 + ps->n_static_syms); psym++)
5342 {
5343 QUIT;
5344 symbol_completion_add (&result, SYMBOL_LINKAGE_NAME (*psym),
5345 text, text_len, text0, word,
5346 wild_match, encoded);
5347 }
96d887e8 5348 }
14f9c5c9 5349
96d887e8
PH
5350 /* At this point scan through the misc symbol vectors and add each
5351 symbol you find to the list. Eventually we want to ignore
5352 anything that isn't a text symbol (everything else will be
5353 handled by the psymtab code above). */
14f9c5c9 5354
96d887e8
PH
5355 ALL_MSYMBOLS (objfile, msymbol)
5356 {
5357 QUIT;
5358 symbol_completion_add (&result, SYMBOL_LINKAGE_NAME (msymbol),
76a01679 5359 text, text_len, text0, word, wild_match, encoded);
96d887e8 5360 }
14f9c5c9 5361
96d887e8
PH
5362 /* Search upwards from currently selected frame (so that we can
5363 complete on local vars. */
14f9c5c9 5364
96d887e8 5365 for (b = get_selected_block (0); b != NULL; b = BLOCK_SUPERBLOCK (b))
14f9c5c9 5366 {
96d887e8 5367 if (!BLOCK_SUPERBLOCK (b))
76a01679 5368 surrounding_static_block = b; /* For elmin of dups */
96d887e8
PH
5369
5370 ALL_BLOCK_SYMBOLS (b, iter, sym)
76a01679
JB
5371 {
5372 symbol_completion_add (&result, SYMBOL_LINKAGE_NAME (sym),
5373 text, text_len, text0, word,
5374 wild_match, encoded);
5375 }
14f9c5c9
AS
5376 }
5377
96d887e8
PH
5378 /* Go through the symtabs and check the externs and statics for
5379 symbols which match. */
14f9c5c9 5380
96d887e8
PH
5381 ALL_SYMTABS (objfile, s)
5382 {
5383 QUIT;
5384 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), GLOBAL_BLOCK);
5385 ALL_BLOCK_SYMBOLS (b, iter, sym)
76a01679
JB
5386 {
5387 symbol_completion_add (&result, SYMBOL_LINKAGE_NAME (sym),
5388 text, text_len, text0, word,
5389 wild_match, encoded);
5390 }
96d887e8 5391 }
14f9c5c9 5392
96d887e8
PH
5393 ALL_SYMTABS (objfile, s)
5394 {
5395 QUIT;
5396 b = BLOCKVECTOR_BLOCK (BLOCKVECTOR (s), STATIC_BLOCK);
5397 /* Don't do this block twice. */
5398 if (b == surrounding_static_block)
5399 continue;
5400 ALL_BLOCK_SYMBOLS (b, iter, sym)
76a01679
JB
5401 {
5402 symbol_completion_add (&result, SYMBOL_LINKAGE_NAME (sym),
5403 text, text_len, text0, word,
5404 wild_match, encoded);
5405 }
96d887e8 5406 }
261397f8 5407
96d887e8
PH
5408 /* Append the closing NULL entry. */
5409 string_vector_append (&result, NULL);
d2e4a39e 5410
96d887e8 5411 return (result.array);
14f9c5c9 5412}
96d887e8 5413
76a01679 5414#endif /* GNAT_GDB */
14f9c5c9 5415\f
96d887e8 5416#ifdef GNAT_GDB
4c4b4cd2 5417 /* Breakpoint-related */
d2e4a39e 5418
14f9c5c9
AS
5419/* Assuming that LINE is pointing at the beginning of an argument to
5420 'break', return a pointer to the delimiter for the initial segment
4c4b4cd2
PH
5421 of that name. This is the first ':', ' ', or end of LINE. */
5422
d2e4a39e
AS
5423char *
5424ada_start_decode_line_1 (char *line)
14f9c5c9 5425{
4c4b4cd2
PH
5426 /* NOTE: strpbrk would be more elegant, but I am reluctant to be
5427 the first to use such a library function in GDB code. */
d2e4a39e 5428 char *p;
14f9c5c9
AS
5429 for (p = line; *p != '\000' && *p != ' ' && *p != ':'; p += 1)
5430 ;
5431 return p;
5432}
5433
5434/* *SPEC points to a function and line number spec (as in a break
5435 command), following any initial file name specification.
5436
5437 Return all symbol table/line specfications (sals) consistent with the
4c4b4cd2 5438 information in *SPEC and FILE_TABLE in the following sense:
14f9c5c9
AS
5439 + FILE_TABLE is null, or the sal refers to a line in the file
5440 named by FILE_TABLE.
5441 + If *SPEC points to an argument with a trailing ':LINENUM',
4c4b4cd2 5442 then the sal refers to that line (or one following it as closely as
14f9c5c9 5443 possible).
4c4b4cd2 5444 + If *SPEC does not start with '*', the sal is in a function with
14f9c5c9
AS
5445 that name.
5446
5447 Returns with 0 elements if no matching non-minimal symbols found.
5448
5449 If *SPEC begins with a function name of the form <NAME>, then NAME
5450 is taken as a literal name; otherwise the function name is subject
4c4b4cd2 5451 to the usual encoding.
14f9c5c9
AS
5452
5453 *SPEC is updated to point after the function/line number specification.
5454
5455 FUNFIRSTLINE is non-zero if we desire the first line of real code
4c4b4cd2 5456 in each function.
14f9c5c9
AS
5457
5458 If CANONICAL is non-NULL, and if any of the sals require a
5459 'canonical line spec', then *CANONICAL is set to point to an array
5460 of strings, corresponding to and equal in length to the returned
4c4b4cd2
PH
5461 list of sals, such that (*CANONICAL)[i] is non-null and contains a
5462 canonical line spec for the ith returned sal, if needed. If no
5463 canonical line specs are required and CANONICAL is non-null,
14f9c5c9
AS
5464 *CANONICAL is set to NULL.
5465
5466 A 'canonical line spec' is simply a name (in the format of the
5467 breakpoint command) that uniquely identifies a breakpoint position,
5468 with no further contextual information or user selection. It is
5469 needed whenever the file name, function name, and line number
5470 information supplied is insufficient for this unique
4c4b4cd2 5471 identification. Currently overloaded functions, the name '*',
14f9c5c9
AS
5472 or static functions without a filename yield a canonical line spec.
5473 The array and the line spec strings are allocated on the heap; it
4c4b4cd2 5474 is the caller's responsibility to free them. */
14f9c5c9
AS
5475
5476struct symtabs_and_lines
d2e4a39e 5477ada_finish_decode_line_1 (char **spec, struct symtab *file_table,
4c4b4cd2 5478 int funfirstline, char ***canonical)
14f9c5c9 5479{
4c4b4cd2
PH
5480 struct ada_symbol_info *symbols;
5481 const struct block *block;
14f9c5c9
AS
5482 int n_matches, i, line_num;
5483 struct symtabs_and_lines selected;
d2e4a39e
AS
5484 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
5485 char *name;
4c4b4cd2 5486 int is_quoted;
14f9c5c9
AS
5487
5488 int len;
d2e4a39e
AS
5489 char *lower_name;
5490 char *unquoted_name;
14f9c5c9 5491
76a01679 5492 if (file_table == NULL)
4c4b4cd2 5493 block = block_static_block (get_selected_block (0));
14f9c5c9
AS
5494 else
5495 block = BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table), STATIC_BLOCK);
5496
5497 if (canonical != NULL)
d2e4a39e 5498 *canonical = (char **) NULL;
14f9c5c9 5499
4c4b4cd2
PH
5500 is_quoted = (**spec && strchr (get_gdb_completer_quote_characters (),
5501 **spec) != NULL);
5502
14f9c5c9 5503 name = *spec;
d2e4a39e 5504 if (**spec == '*')
14f9c5c9
AS
5505 *spec += 1;
5506 else
5507 {
4c4b4cd2
PH
5508 if (is_quoted)
5509 *spec = skip_quoted (*spec);
1265e4aa
JB
5510 while (**spec != '\000'
5511 && !strchr (ada_completer_word_break_characters, **spec))
4c4b4cd2 5512 *spec += 1;
14f9c5c9
AS
5513 }
5514 len = *spec - name;
5515
5516 line_num = -1;
5517 if (file_table != NULL && (*spec)[0] == ':' && isdigit ((*spec)[1]))
5518 {
5519 line_num = strtol (*spec + 1, spec, 10);
d2e4a39e 5520 while (**spec == ' ' || **spec == '\t')
4c4b4cd2 5521 *spec += 1;
14f9c5c9
AS
5522 }
5523
d2e4a39e 5524 if (name[0] == '*')
14f9c5c9
AS
5525 {
5526 if (line_num == -1)
4c4b4cd2 5527 error ("Wild-card function with no line number or file name.");
14f9c5c9 5528
4c4b4cd2
PH
5529 return ada_sals_for_line (file_table->filename, line_num,
5530 funfirstline, canonical, 0);
14f9c5c9
AS
5531 }
5532
5533 if (name[0] == '\'')
5534 {
5535 name += 1;
5536 len -= 2;
5537 }
5538
5539 if (name[0] == '<')
5540 {
d2e4a39e
AS
5541 unquoted_name = (char *) alloca (len - 1);
5542 memcpy (unquoted_name, name + 1, len - 2);
5543 unquoted_name[len - 2] = '\000';
14f9c5c9
AS
5544 lower_name = NULL;
5545 }
5546 else
5547 {
d2e4a39e 5548 unquoted_name = (char *) alloca (len + 1);
14f9c5c9
AS
5549 memcpy (unquoted_name, name, len);
5550 unquoted_name[len] = '\000';
d2e4a39e 5551 lower_name = (char *) alloca (len + 1);
14f9c5c9 5552 for (i = 0; i < len; i += 1)
4c4b4cd2 5553 lower_name[i] = tolower (name[i]);
14f9c5c9
AS
5554 lower_name[len] = '\000';
5555 }
5556
5557 n_matches = 0;
d2e4a39e 5558 if (lower_name != NULL)
4c4b4cd2
PH
5559 n_matches = ada_lookup_symbol_list (ada_encode (lower_name), block,
5560 VAR_DOMAIN, &symbols);
14f9c5c9 5561 if (n_matches == 0)
d2e4a39e 5562 n_matches = ada_lookup_symbol_list (unquoted_name, block,
4c4b4cd2 5563 VAR_DOMAIN, &symbols);
14f9c5c9
AS
5564 if (n_matches == 0 && line_num >= 0)
5565 error ("No line number information found for %s.", unquoted_name);
5566 else if (n_matches == 0)
5567 {
5568#ifdef HPPA_COMPILER_BUG
5569 /* FIXME: See comment in symtab.c::decode_line_1 */
5570#undef volatile
5571 volatile struct symtab_and_line val;
4c4b4cd2 5572#define volatile /*nothing */
14f9c5c9
AS
5573#else
5574 struct symtab_and_line val;
5575#endif
d2e4a39e 5576 struct minimal_symbol *msymbol;
14f9c5c9 5577
fe39c653 5578 init_sal (&val);
14f9c5c9
AS
5579
5580 msymbol = NULL;
d2e4a39e 5581 if (lower_name != NULL)
4c4b4cd2 5582 msymbol = ada_lookup_simple_minsym (ada_encode (lower_name));
14f9c5c9 5583 if (msymbol == NULL)
4c4b4cd2 5584 msymbol = ada_lookup_simple_minsym (unquoted_name);
14f9c5c9 5585 if (msymbol != NULL)
4c4b4cd2
PH
5586 {
5587 val.pc = SYMBOL_VALUE_ADDRESS (msymbol);
5588 val.section = SYMBOL_BFD_SECTION (msymbol);
5589 if (funfirstline)
5590 {
782263ab 5591 val.pc += DEPRECATED_FUNCTION_START_OFFSET;
4c4b4cd2
PH
5592 SKIP_PROLOGUE (val.pc);
5593 }
5594 selected.sals = (struct symtab_and_line *)
5595 xmalloc (sizeof (struct symtab_and_line));
5596 selected.sals[0] = val;
5597 selected.nelts = 1;
5598 return selected;
5599 }
d2e4a39e 5600
1265e4aa
JB
5601 if (!have_full_symbols ()
5602 && !have_partial_symbols () && !have_minimal_symbols ())
4c4b4cd2 5603 error ("No symbol table is loaded. Use the \"file\" command.");
14f9c5c9
AS
5604
5605 error ("Function \"%s\" not defined.", unquoted_name);
4c4b4cd2 5606 return selected; /* for lint */
14f9c5c9
AS
5607 }
5608
5609 if (line_num >= 0)
5610 {
4c4b4cd2
PH
5611 struct symtabs_and_lines best_sal =
5612 find_sal_from_funcs_and_line (file_table->filename, line_num,
5613 symbols, n_matches);
5614 if (funfirstline)
5615 adjust_pc_past_prologue (&best_sal.sals[0].pc);
5616 return best_sal;
14f9c5c9
AS
5617 }
5618 else
5619 {
76a01679 5620 selected.nelts = user_select_syms (symbols, n_matches, n_matches);
14f9c5c9
AS
5621 }
5622
d2e4a39e 5623 selected.sals = (struct symtab_and_line *)
14f9c5c9
AS
5624 xmalloc (sizeof (struct symtab_and_line) * selected.nelts);
5625 memset (selected.sals, 0, selected.nelts * sizeof (selected.sals[i]));
aacb1f0a 5626 make_cleanup (xfree, selected.sals);
14f9c5c9
AS
5627
5628 i = 0;
5629 while (i < selected.nelts)
5630 {
4c4b4cd2 5631 if (SYMBOL_CLASS (symbols[i].sym) == LOC_BLOCK)
76a01679
JB
5632 selected.sals[i]
5633 = find_function_start_sal (symbols[i].sym, funfirstline);
4c4b4cd2
PH
5634 else if (SYMBOL_LINE (symbols[i].sym) != 0)
5635 {
76a01679
JB
5636 selected.sals[i].symtab =
5637 symbols[i].symtab
5638 ? symbols[i].symtab : symtab_for_sym (symbols[i].sym);
4c4b4cd2
PH
5639 selected.sals[i].line = SYMBOL_LINE (symbols[i].sym);
5640 }
14f9c5c9 5641 else if (line_num >= 0)
4c4b4cd2
PH
5642 {
5643 /* Ignore this choice */
5644 symbols[i] = symbols[selected.nelts - 1];
5645 selected.nelts -= 1;
5646 continue;
5647 }
d2e4a39e 5648 else
4c4b4cd2 5649 error ("Line number not known for symbol \"%s\"", unquoted_name);
14f9c5c9
AS
5650 i += 1;
5651 }
5652
5653 if (canonical != NULL && (line_num >= 0 || n_matches > 1))
5654 {
d2e4a39e 5655 *canonical = (char **) xmalloc (sizeof (char *) * selected.nelts);
14f9c5c9 5656 for (i = 0; i < selected.nelts; i += 1)
4c4b4cd2
PH
5657 (*canonical)[i] =
5658 extended_canonical_line_spec (selected.sals[i],
5659 SYMBOL_PRINT_NAME (symbols[i].sym));
14f9c5c9 5660 }
d2e4a39e 5661
14f9c5c9
AS
5662 discard_cleanups (old_chain);
5663 return selected;
d2e4a39e
AS
5664}
5665
14f9c5c9 5666/* The (single) sal corresponding to line LINE_NUM in a symbol table
4c4b4cd2
PH
5667 with file name FILENAME that occurs in one of the functions listed
5668 in the symbol fields of SYMBOLS[0 .. NSYMS-1]. */
5669
14f9c5c9 5670static struct symtabs_and_lines
d2e4a39e 5671find_sal_from_funcs_and_line (const char *filename, int line_num,
4c4b4cd2 5672 struct ada_symbol_info *symbols, int nsyms)
14f9c5c9
AS
5673{
5674 struct symtabs_and_lines sals;
5675 int best_index, best;
d2e4a39e
AS
5676 struct linetable *best_linetable;
5677 struct objfile *objfile;
5678 struct symtab *s;
5679 struct symtab *best_symtab;
14f9c5c9
AS
5680
5681 read_all_symtabs (filename);
5682
d2e4a39e
AS
5683 best_index = 0;
5684 best_linetable = NULL;
5685 best_symtab = NULL;
14f9c5c9
AS
5686 best = 0;
5687 ALL_SYMTABS (objfile, s)
d2e4a39e
AS
5688 {
5689 struct linetable *l;
5690 int ind, exact;
14f9c5c9 5691
d2e4a39e 5692 QUIT;
14f9c5c9 5693
4c4b4cd2 5694 if (strcmp (filename, s->filename) != 0)
d2e4a39e
AS
5695 continue;
5696 l = LINETABLE (s);
5697 ind = find_line_in_linetable (l, line_num, symbols, nsyms, &exact);
5698 if (ind >= 0)
5699 {
4c4b4cd2
PH
5700 if (exact)
5701 {
5702 best_index = ind;
5703 best_linetable = l;
5704 best_symtab = s;
5705 goto done;
5706 }
5707 if (best == 0 || l->item[ind].line < best)
5708 {
5709 best = l->item[ind].line;
5710 best_index = ind;
5711 best_linetable = l;
5712 best_symtab = s;
5713 }
d2e4a39e
AS
5714 }
5715 }
14f9c5c9
AS
5716
5717 if (best == 0)
5718 error ("Line number not found in designated function.");
5719
d2e4a39e
AS
5720done:
5721
14f9c5c9 5722 sals.nelts = 1;
d2e4a39e 5723 sals.sals = (struct symtab_and_line *) xmalloc (sizeof (sals.sals[0]));
14f9c5c9 5724
fe39c653 5725 init_sal (&sals.sals[0]);
d2e4a39e 5726
14f9c5c9
AS
5727 sals.sals[0].line = best_linetable->item[best_index].line;
5728 sals.sals[0].pc = best_linetable->item[best_index].pc;
5729 sals.sals[0].symtab = best_symtab;
5730
5731 return sals;
5732}
5733
5734/* Return the index in LINETABLE of the best match for LINE_NUM whose
4c4b4cd2
PH
5735 pc falls within one of the functions denoted by the symbol fields
5736 of SYMBOLS[0..NSYMS-1]. Set *EXACTP to 1 if the match is exact,
5737 and 0 otherwise. */
5738
14f9c5c9 5739static int
d2e4a39e 5740find_line_in_linetable (struct linetable *linetable, int line_num,
76a01679
JB
5741 struct ada_symbol_info *symbols, int nsyms,
5742 int *exactp)
14f9c5c9
AS
5743{
5744 int i, len, best_index, best;
5745
5746 if (line_num <= 0 || linetable == NULL)
5747 return -1;
5748
5749 len = linetable->nitems;
5750 for (i = 0, best_index = -1, best = 0; i < len; i += 1)
5751 {
5752 int k;
d2e4a39e 5753 struct linetable_entry *item = &(linetable->item[i]);
14f9c5c9
AS
5754
5755 for (k = 0; k < nsyms; k += 1)
4c4b4cd2 5756 {
76a01679
JB
5757 if (symbols[k].sym != NULL
5758 && SYMBOL_CLASS (symbols[k].sym) == LOC_BLOCK
4c4b4cd2
PH
5759 && item->pc >= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols[k].sym))
5760 && item->pc < BLOCK_END (SYMBOL_BLOCK_VALUE (symbols[k].sym)))
5761 goto candidate;
5762 }
14f9c5c9
AS
5763 continue;
5764
5765 candidate:
5766
5767 if (item->line == line_num)
4c4b4cd2
PH
5768 {
5769 *exactp = 1;
5770 return i;
5771 }
14f9c5c9
AS
5772
5773 if (item->line > line_num && (best == 0 || item->line < best))
4c4b4cd2
PH
5774 {
5775 best = item->line;
5776 best_index = i;
5777 }
14f9c5c9
AS
5778 }
5779
5780 *exactp = 0;
5781 return best_index;
5782}
5783
5784/* Find the smallest k >= LINE_NUM such that k is a line number in
5785 LINETABLE, and k falls strictly within a named function that begins at
4c4b4cd2
PH
5786 or before LINE_NUM. Return -1 if there is no such k. */
5787
14f9c5c9 5788static int
d2e4a39e 5789nearest_line_number_in_linetable (struct linetable *linetable, int line_num)
14f9c5c9
AS
5790{
5791 int i, len, best;
5792
5793 if (line_num <= 0 || linetable == NULL || linetable->nitems == 0)
5794 return -1;
5795 len = linetable->nitems;
5796
d2e4a39e
AS
5797 i = 0;
5798 best = INT_MAX;
14f9c5c9
AS
5799 while (i < len)
5800 {
d2e4a39e 5801 struct linetable_entry *item = &(linetable->item[i]);
14f9c5c9
AS
5802
5803 if (item->line >= line_num && item->line < best)
4c4b4cd2
PH
5804 {
5805 char *func_name;
5806 CORE_ADDR start, end;
5807
5808 func_name = NULL;
5809 find_pc_partial_function (item->pc, &func_name, &start, &end);
5810
5811 if (func_name != NULL && item->pc < end)
5812 {
5813 if (item->line == line_num)
5814 return line_num;
5815 else
5816 {
5817 struct symbol *sym =
5818 standard_lookup (func_name, NULL, VAR_DOMAIN);
5819 if (is_plausible_func_for_line (sym, line_num))
5820 best = item->line;
5821 else
5822 {
5823 do
5824 i += 1;
5825 while (i < len && linetable->item[i].pc < end);
5826 continue;
5827 }
5828 }
5829 }
5830 }
14f9c5c9
AS
5831
5832 i += 1;
5833 }
5834
5835 return (best == INT_MAX) ? -1 : best;
5836}
5837
5838
4c4b4cd2 5839/* Return the next higher index, k, into LINETABLE such that k > IND,
14f9c5c9 5840 entry k in LINETABLE has a line number equal to LINE_NUM, k
4c4b4cd2 5841 corresponds to a PC that is in a function different from that
14f9c5c9 5842 corresponding to IND, and falls strictly within a named function
4c4b4cd2
PH
5843 that begins at a line at or preceding STARTING_LINE.
5844 Return -1 if there is no such k.
5845 IND == -1 corresponds to no function. */
14f9c5c9
AS
5846
5847static int
d2e4a39e 5848find_next_line_in_linetable (struct linetable *linetable, int line_num,
4c4b4cd2 5849 int starting_line, int ind)
14f9c5c9
AS
5850{
5851 int i, len;
5852
5853 if (line_num <= 0 || linetable == NULL || ind >= linetable->nitems)
5854 return -1;
5855 len = linetable->nitems;
5856
d2e4a39e 5857 if (ind >= 0)
14f9c5c9
AS
5858 {
5859 CORE_ADDR start, end;
5860
5861 if (find_pc_partial_function (linetable->item[ind].pc,
4c4b4cd2
PH
5862 (char **) NULL, &start, &end))
5863 {
5864 while (ind < len && linetable->item[ind].pc < end)
5865 ind += 1;
5866 }
14f9c5c9 5867 else
4c4b4cd2 5868 ind += 1;
14f9c5c9
AS
5869 }
5870 else
5871 ind = 0;
5872
5873 i = ind;
5874 while (i < len)
5875 {
d2e4a39e 5876 struct linetable_entry *item = &(linetable->item[i]);
14f9c5c9
AS
5877
5878 if (item->line >= line_num)
4c4b4cd2
PH
5879 {
5880 char *func_name;
5881 CORE_ADDR start, end;
5882
5883 func_name = NULL;
5884 find_pc_partial_function (item->pc, &func_name, &start, &end);
5885
5886 if (func_name != NULL && item->pc < end)
5887 {
5888 if (item->line == line_num)
5889 {
5890 struct symbol *sym =
5891 standard_lookup (func_name, NULL, VAR_DOMAIN);
5892 if (is_plausible_func_for_line (sym, starting_line))
5893 return i;
5894 else
5895 {
5896 while ((i + 1) < len && linetable->item[i + 1].pc < end)
5897 i += 1;
5898 }
5899 }
5900 }
5901 }
14f9c5c9
AS
5902 i += 1;
5903 }
5904
5905 return -1;
5906}
5907
5908/* True iff function symbol SYM starts somewhere at or before line #
4c4b4cd2
PH
5909 LINE_NUM. */
5910
14f9c5c9 5911static int
d2e4a39e 5912is_plausible_func_for_line (struct symbol *sym, int line_num)
14f9c5c9
AS
5913{
5914 struct symtab_and_line start_sal;
5915
5916 if (sym == NULL)
5917 return 0;
5918
5919 start_sal = find_function_start_sal (sym, 0);
5920
5921 return (start_sal.line != 0 && line_num >= start_sal.line);
5922}
5923
14f9c5c9 5924/* Read in all symbol tables corresponding to partial symbol tables
4c4b4cd2
PH
5925 with file name FILENAME. */
5926
14f9c5c9 5927static void
d2e4a39e 5928read_all_symtabs (const char *filename)
14f9c5c9 5929{
d2e4a39e
AS
5930 struct partial_symtab *ps;
5931 struct objfile *objfile;
14f9c5c9
AS
5932
5933 ALL_PSYMTABS (objfile, ps)
d2e4a39e
AS
5934 {
5935 QUIT;
14f9c5c9 5936
4c4b4cd2 5937 if (strcmp (filename, ps->filename) == 0)
d2e4a39e
AS
5938 PSYMTAB_TO_SYMTAB (ps);
5939 }
14f9c5c9
AS
5940}
5941
5942/* All sals corresponding to line LINE_NUM in a symbol table from file
4c4b4cd2
PH
5943 FILENAME, as filtered by the user. Filter out any lines that
5944 reside in functions with "suppressed" names (not corresponding to
5945 explicit Ada functions), if there is at least one in a function
5946 with a non-suppressed name. If CANONICAL is not null, set
5947 it to a corresponding array of canonical line specs.
5948 If ONE_LOCATION_ONLY is set and several matches are found for
5949 the given location, then automatically select the first match found
5950 instead of asking the user which instance should be returned. */
5951
5952struct symtabs_and_lines
5953ada_sals_for_line (const char *filename, int line_num,
76a01679 5954 int funfirstline, char ***canonical, int one_location_only)
14f9c5c9
AS
5955{
5956 struct symtabs_and_lines result;
d2e4a39e
AS
5957 struct objfile *objfile;
5958 struct symtab *s;
5959 struct cleanup *old_chain = make_cleanup (null_cleanup, NULL);
14f9c5c9
AS
5960 size_t len;
5961
5962 read_all_symtabs (filename);
5963
d2e4a39e
AS
5964 result.sals =
5965 (struct symtab_and_line *) xmalloc (4 * sizeof (result.sals[0]));
14f9c5c9
AS
5966 result.nelts = 0;
5967 len = 4;
5968 make_cleanup (free_current_contents, &result.sals);
5969
d2e4a39e
AS
5970 ALL_SYMTABS (objfile, s)
5971 {
5972 int ind, target_line_num;
14f9c5c9 5973
d2e4a39e 5974 QUIT;
14f9c5c9 5975
4c4b4cd2 5976 if (strcmp (s->filename, filename) != 0)
d2e4a39e 5977 continue;
14f9c5c9 5978
d2e4a39e
AS
5979 target_line_num =
5980 nearest_line_number_in_linetable (LINETABLE (s), line_num);
5981 if (target_line_num == -1)
5982 continue;
14f9c5c9 5983
d2e4a39e
AS
5984 ind = -1;
5985 while (1)
5986 {
4c4b4cd2
PH
5987 ind =
5988 find_next_line_in_linetable (LINETABLE (s),
5989 target_line_num, line_num, ind);
14f9c5c9 5990
4c4b4cd2
PH
5991 if (ind < 0)
5992 break;
5993
5994 GROW_VECT (result.sals, len, result.nelts + 1);
5995 init_sal (&result.sals[result.nelts]);
5996 result.sals[result.nelts].line = line_num;
5997 result.sals[result.nelts].pc = LINETABLE (s)->item[ind].pc;
5998 result.sals[result.nelts].symtab = s;
d2e4a39e 5999
4c4b4cd2
PH
6000 if (funfirstline)
6001 adjust_pc_past_prologue (&result.sals[result.nelts].pc);
6002
6003 result.nelts += 1;
d2e4a39e
AS
6004 }
6005 }
14f9c5c9
AS
6006
6007 if (canonical != NULL || result.nelts > 1)
6008 {
4c4b4cd2 6009 int k, j, n;
d2e4a39e 6010 char **func_names = (char **) alloca (result.nelts * sizeof (char *));
14f9c5c9 6011 int first_choice = (result.nelts > 1) ? 2 : 1;
d2e4a39e
AS
6012 int *choices = (int *) alloca (result.nelts * sizeof (int));
6013
6014 for (k = 0; k < result.nelts; k += 1)
4c4b4cd2
PH
6015 {
6016 find_pc_partial_function (result.sals[k].pc, &func_names[k],
6017 (CORE_ADDR *) NULL, (CORE_ADDR *) NULL);
6018 if (func_names[k] == NULL)
6019 error ("Could not find function for one or more breakpoints.");
6020 }
6021
6022 /* Remove suppressed names, unless all are suppressed. */
6023 for (j = 0; j < result.nelts; j += 1)
6024 if (!is_suppressed_name (func_names[j]))
6025 {
6026 /* At least one name is unsuppressed, so remove all
6027 suppressed names. */
6028 for (k = n = 0; k < result.nelts; k += 1)
6029 if (!is_suppressed_name (func_names[k]))
6030 {
6031 func_names[n] = func_names[k];
6032 result.sals[n] = result.sals[k];
6033 n += 1;
6034 }
6035 result.nelts = n;
6036 break;
6037 }
d2e4a39e
AS
6038
6039 if (result.nelts > 1)
4c4b4cd2
PH
6040 {
6041 if (one_location_only)
6042 {
6043 /* Automatically select the first of all possible choices. */
6044 n = 1;
6045 choices[0] = 0;
6046 }
6047 else
6048 {
6049 printf_unfiltered ("[0] cancel\n");
6050 if (result.nelts > 1)
6051 printf_unfiltered ("[1] all\n");
6052 for (k = 0; k < result.nelts; k += 1)
6053 printf_unfiltered ("[%d] %s\n", k + first_choice,
6054 ada_decode (func_names[k]));
6055
6056 n = get_selections (choices, result.nelts, result.nelts,
6057 result.nelts > 1, "instance-choice");
6058 }
6059
6060 for (k = 0; k < n; k += 1)
6061 {
6062 result.sals[k] = result.sals[choices[k]];
6063 func_names[k] = func_names[choices[k]];
6064 }
6065 result.nelts = n;
6066 }
6067
6068 if (canonical != NULL && result.nelts == 0)
6069 *canonical = NULL;
6070 else if (canonical != NULL)
6071 {
6072 *canonical = (char **) xmalloc (result.nelts * sizeof (char **));
6073 make_cleanup (xfree, *canonical);
6074 for (k = 0; k < result.nelts; k += 1)
6075 {
6076 (*canonical)[k] =
6077 extended_canonical_line_spec (result.sals[k], func_names[k]);
6078 if ((*canonical)[k] == NULL)
6079 error ("Could not locate one or more breakpoints.");
6080 make_cleanup (xfree, (*canonical)[k]);
6081 }
6082 }
6083 }
6084
6085 if (result.nelts == 0)
6086 {
6087 do_cleanups (old_chain);
6088 result.sals = NULL;
14f9c5c9 6089 }
4c4b4cd2
PH
6090 else
6091 discard_cleanups (old_chain);
14f9c5c9
AS
6092 return result;
6093}
6094
6095
6096/* A canonical line specification of the form FILE:NAME:LINENUM for
6097 symbol table and line data SAL. NULL if insufficient
4c4b4cd2
PH
6098 information. The caller is responsible for releasing any space
6099 allocated. */
14f9c5c9 6100
d2e4a39e
AS
6101static char *
6102extended_canonical_line_spec (struct symtab_and_line sal, const char *name)
14f9c5c9 6103{
d2e4a39e 6104 char *r;
14f9c5c9 6105
d2e4a39e 6106 if (sal.symtab == NULL || sal.symtab->filename == NULL || sal.line <= 0)
14f9c5c9
AS
6107 return NULL;
6108
d2e4a39e 6109 r = (char *) xmalloc (strlen (name) + strlen (sal.symtab->filename)
4c4b4cd2 6110 + sizeof (sal.line) * 3 + 3);
14f9c5c9
AS
6111 sprintf (r, "%s:'%s':%d", sal.symtab->filename, name, sal.line);
6112 return r;
6113}
6114
4c4b4cd2
PH
6115/* Return type of Ada breakpoint associated with bp_stat:
6116 0 if not an Ada-specific breakpoint, 1 for break on specific exception,
6117 2 for break on unhandled exception, 3 for assert. */
6118
6119static int
6120ada_exception_breakpoint_type (bpstat bs)
6121{
76a01679
JB
6122 return ((!bs || !bs->breakpoint_at) ? 0
6123 : bs->breakpoint_at->break_on_exception);
4c4b4cd2
PH
6124}
6125
6126/* True iff FRAME is very likely to be that of a function that is
6127 part of the runtime system. This is all very heuristic, but is
6128 intended to be used as advice as to what frames are uninteresting
6129 to most users. */
6130
6131static int
6132is_known_support_routine (struct frame_info *frame)
6133{
6134 struct frame_info *next_frame = get_next_frame (frame);
6135 /* If frame is not innermost, that normally means that frame->pc
6136 points to *after* the call instruction, and we want to get the line
6137 containing the call, never the next line. But if the next frame is
6138 a signal_handler_caller or a dummy frame, then the next frame was
6139 not entered as the result of a call, and we want to get the line
6140 containing frame->pc. */
76a01679 6141 const int pc_is_after_call =
4c4b4cd2
PH
6142 next_frame != NULL
6143 && get_frame_type (next_frame) != SIGTRAMP_FRAME
6144 && get_frame_type (next_frame) != DUMMY_FRAME;
76a01679 6145 struct symtab_and_line sal
4c4b4cd2
PH
6146 = find_pc_line (get_frame_pc (frame), pc_is_after_call);
6147 char *func_name;
6148 int i;
6149 struct stat st;
6150
6151 /* The heuristic:
76a01679
JB
6152 1. The symtab is null (indicating no debugging symbols)
6153 2. The symtab's filename does not exist.
6154 3. The object file's name is one of the standard libraries.
6155 4. The symtab's file name has the form of an Ada library source file.
6156 5. The function at frame's PC has a GNAT-compiler-generated name. */
4c4b4cd2
PH
6157
6158 if (sal.symtab == NULL)
6159 return 1;
6160
6161 /* On some systems (e.g. VxWorks), the kernel contains debugging
6162 symbols; in this case, the filename referenced by these symbols
6163 does not exists. */
6164
6165 if (stat (sal.symtab->filename, &st))
6166 return 1;
6167
6168 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
6169 {
6170 re_comp (known_runtime_file_name_patterns[i]);
6171 if (re_exec (sal.symtab->filename))
6172 return 1;
6173 }
6174 if (sal.symtab->objfile != NULL)
6175 {
6176 for (i = 0; known_runtime_file_name_patterns[i] != NULL; i += 1)
6177 {
6178 re_comp (known_runtime_file_name_patterns[i]);
6179 if (re_exec (sal.symtab->objfile->name))
6180 return 1;
6181 }
6182 }
6183
6184 /* If the frame PC points after the call instruction, then we need to
6185 decrement it in order to search for the function associated to this
6186 PC. Otherwise, if the associated call was the last instruction of
6187 the function, we might either find the wrong function or even fail
6188 during the function name lookup. */
6189 if (pc_is_after_call)
6190 func_name = function_name_from_pc (get_frame_pc (frame) - 1);
6191 else
6192 func_name = function_name_from_pc (get_frame_pc (frame));
6193
6194 if (func_name == NULL)
6195 return 1;
6196
6197 for (i = 0; known_auxiliary_function_name_patterns[i] != NULL; i += 1)
6198 {
6199 re_comp (known_auxiliary_function_name_patterns[i]);
6200 if (re_exec (func_name))
6201 return 1;
6202 }
6203
6204 return 0;
6205}
6206
6207/* Find the first frame that contains debugging information and that is not
6208 part of the Ada run-time, starting from FI and moving upward. */
6209
6210void
6211ada_find_printable_frame (struct frame_info *fi)
14f9c5c9 6212{
4c4b4cd2
PH
6213 for (; fi != NULL; fi = get_prev_frame (fi))
6214 {
6215 if (!is_known_support_routine (fi))
6216 {
6217 select_frame (fi);
6218 break;
6219 }
6220 }
14f9c5c9 6221
4c4b4cd2 6222}
d2e4a39e 6223
4c4b4cd2
PH
6224/* Name found for exception associated with last bpstat sent to
6225 ada_adjust_exception_stop. Set to the null string if that bpstat
6226 did not correspond to an Ada exception or no name could be found. */
14f9c5c9 6227
4c4b4cd2 6228static char last_exception_name[256];
14f9c5c9 6229
4c4b4cd2
PH
6230/* If BS indicates a stop in an Ada exception, try to go up to a frame
6231 that will be meaningful to the user, and save the name of the last
6232 exception (truncated, if necessary) in last_exception_name. */
14f9c5c9 6233
4c4b4cd2
PH
6234void
6235ada_adjust_exception_stop (bpstat bs)
6236{
6237 CORE_ADDR addr;
6238 struct frame_info *fi;
6239 int frame_level;
6240 char *selected_frame_func;
14f9c5c9 6241
4c4b4cd2
PH
6242 addr = 0;
6243 last_exception_name[0] = '\0';
6244 fi = get_selected_frame ();
6245 selected_frame_func = function_name_from_pc (get_frame_pc (fi));
6246
6247 switch (ada_exception_breakpoint_type (bs))
d2e4a39e 6248 {
4c4b4cd2
PH
6249 default:
6250 return;
6251 case 1:
6252 break;
6253 case 2:
6254 /* Unhandled exceptions. Select the frame corresponding to
6255 ada.exceptions.process_raise_exception. This frame is at
6256 least 2 levels up, so we simply skip the first 2 frames
6257 without checking the name of their associated function. */
6258 for (frame_level = 0; frame_level < 2; frame_level += 1)
6259 if (fi != NULL)
76a01679 6260 fi = get_prev_frame (fi);
4c4b4cd2
PH
6261 while (fi != NULL)
6262 {
6263 const char *func_name = function_name_from_pc (get_frame_pc (fi));
6264 if (func_name != NULL
6265 && strcmp (func_name, process_raise_exception_name) == 0)
76a01679 6266 break; /* We found the frame we were looking for... */
4c4b4cd2
PH
6267 fi = get_prev_frame (fi);
6268 }
6269 if (fi == NULL)
76a01679 6270 break;
4c4b4cd2
PH
6271 select_frame (fi);
6272 break;
d2e4a39e 6273 }
14f9c5c9 6274
76a01679 6275 addr = parse_and_eval_address ("e.full_name");
4c4b4cd2
PH
6276
6277 if (addr != 0)
76a01679 6278 read_memory (addr, last_exception_name, sizeof (last_exception_name) - 1);
4c4b4cd2
PH
6279 last_exception_name[sizeof (last_exception_name) - 1] = '\0';
6280 ada_find_printable_frame (get_selected_frame ());
14f9c5c9
AS
6281}
6282
4c4b4cd2
PH
6283/* Output Ada exception name (if any) associated with last call to
6284 ada_adjust_exception_stop. */
6285
6286void
6287ada_print_exception_stop (bpstat bs)
14f9c5c9 6288{
4c4b4cd2
PH
6289 if (last_exception_name[0] != '\000')
6290 {
6291 ui_out_text (uiout, last_exception_name);
6292 ui_out_text (uiout, " at ");
6293 }
14f9c5c9
AS
6294}
6295
4c4b4cd2
PH
6296/* Parses the CONDITION string associated with a breakpoint exception
6297 to get the name of the exception on which the breakpoint has been
6298 set. The returned string needs to be deallocated after use. */
14f9c5c9 6299
4c4b4cd2
PH
6300static char *
6301exception_name_from_cond (const char *condition)
14f9c5c9 6302{
4c4b4cd2
PH
6303 char *start, *end, *exception_name;
6304 int exception_name_len;
d2e4a39e 6305
4c4b4cd2
PH
6306 start = strrchr (condition, '&') + 1;
6307 end = strchr (start, ')') - 1;
6308 exception_name_len = end - start + 1;
14f9c5c9 6309
4c4b4cd2
PH
6310 exception_name =
6311 (char *) xmalloc ((exception_name_len + 1) * sizeof (char));
6312 sprintf (exception_name, "%.*s", exception_name_len, start);
6313
6314 return exception_name;
6315}
6316
6317/* Print Ada-specific exception information about B, other than task
6318 clause. Return non-zero iff B was an Ada exception breakpoint. */
14f9c5c9 6319
4c4b4cd2
PH
6320int
6321ada_print_exception_breakpoint_nontask (struct breakpoint *b)
6322{
4c4b4cd2
PH
6323 if (b->break_on_exception == 1)
6324 {
76a01679 6325 if (b->cond_string) /* the breakpoint is on a specific exception. */
4c4b4cd2
PH
6326 {
6327 char *exception_name = exception_name_from_cond (b->cond_string);
6328
6329 make_cleanup (xfree, exception_name);
6330
6331 ui_out_text (uiout, "on ");
6332 if (ui_out_is_mi_like_p (uiout))
6333 ui_out_field_string (uiout, "exception", exception_name);
6334 else
6335 {
6336 ui_out_text (uiout, "exception ");
6337 ui_out_text (uiout, exception_name);
6338 ui_out_text (uiout, " ");
6339 }
6340 }
6341 else
6342 ui_out_text (uiout, "on all exceptions");
6343 }
6344 else if (b->break_on_exception == 2)
6345 ui_out_text (uiout, "on unhandled exception");
6346 else if (b->break_on_exception == 3)
6347 ui_out_text (uiout, "on assert failure");
6348 else
6349 return 0;
6350 return 1;
14f9c5c9
AS
6351}
6352
4c4b4cd2
PH
6353/* Print task identifier for breakpoint B, if it is an Ada-specific
6354 breakpoint with non-zero tasking information. */
6355
14f9c5c9 6356void
4c4b4cd2
PH
6357ada_print_exception_breakpoint_task (struct breakpoint *b)
6358{
4c4b4cd2
PH
6359 if (b->task != 0)
6360 {
6361 ui_out_text (uiout, " task ");
6362 ui_out_field_int (uiout, "task", b->task);
6363 }
14f9c5c9
AS
6364}
6365
6366int
d2e4a39e 6367ada_is_exception_sym (struct symbol *sym)
14f9c5c9
AS
6368{
6369 char *type_name = type_name_no_tag (SYMBOL_TYPE (sym));
d2e4a39e 6370
14f9c5c9 6371 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
4c4b4cd2
PH
6372 && SYMBOL_CLASS (sym) != LOC_BLOCK
6373 && SYMBOL_CLASS (sym) != LOC_CONST
6374 && type_name != NULL && strcmp (type_name, "exception") == 0);
14f9c5c9
AS
6375}
6376
6377int
d2e4a39e 6378ada_maybe_exception_partial_symbol (struct partial_symbol *sym)
14f9c5c9
AS
6379{
6380 return (SYMBOL_CLASS (sym) != LOC_TYPEDEF
4c4b4cd2
PH
6381 && SYMBOL_CLASS (sym) != LOC_BLOCK
6382 && SYMBOL_CLASS (sym) != LOC_CONST);
6383}
6384
6385/* Cause the appropriate error if no appropriate runtime symbol is
6386 found to set a breakpoint, using ERR_DESC to describe the
6387 breakpoint. */
6388
6389static void
6390error_breakpoint_runtime_sym_not_found (const char *err_desc)
6391{
6392 /* If we are not debugging an Ada program, we can not put exception
6393 breakpoints! */
6394
6395 if (ada_update_initial_language (language_unknown, NULL) != language_ada)
6396 error ("Unable to break on %s. Is this an Ada main program?", err_desc);
6397
6398 /* If the symbol does not exist, then check that the program is
6399 already started, to make sure that shared libraries have been
6400 loaded. If it is not started, this may mean that the symbol is
6401 in a shared library. */
6402
6403 if (ptid_get_pid (inferior_ptid) == 0)
76a01679
JB
6404 error ("Unable to break on %s. Try to start the program first.",
6405 err_desc);
4c4b4cd2
PH
6406
6407 /* At this point, we know that we are debugging an Ada program and
6408 that the inferior has been started, but we still are not able to
6409 find the run-time symbols. That can mean that we are in
6410 configurable run time mode, or that a-except as been optimized
6411 out by the linker... In any case, at this point it is not worth
6412 supporting this feature. */
6413
6414 error ("Cannot break on %s in this configuration.", err_desc);
6415}
6416
6417/* Test if NAME is currently defined, and that either ALLOW_TRAMP or
6418 the symbol is not a shared-library trampoline. Return the result of
6419 the test. */
6420
6421static int
76a01679 6422is_runtime_sym_defined (const char *name, int allow_tramp)
4c4b4cd2
PH
6423{
6424 struct minimal_symbol *msym;
6425
6426 msym = lookup_minimal_symbol (name, NULL, NULL);
6427 return (msym != NULL && msym->type != mst_unknown
76a01679 6428 && (allow_tramp || msym->type != mst_solib_trampoline));
14f9c5c9
AS
6429}
6430
6431/* If ARG points to an Ada exception or assert breakpoint, rewrite
4c4b4cd2 6432 into equivalent form. Return resulting argument string. Set
14f9c5c9 6433 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
4c4b4cd2
PH
6434 break on unhandled, 3 for assert, 0 otherwise. */
6435
d2e4a39e
AS
6436char *
6437ada_breakpoint_rewrite (char *arg, int *break_on_exceptionp)
14f9c5c9
AS
6438{
6439 if (arg == NULL)
6440 return arg;
6441 *break_on_exceptionp = 0;
4c4b4cd2
PH
6442 if (current_language->la_language == language_ada
6443 && strncmp (arg, "exception", 9) == 0
6444 && (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
6445 {
6446 char *tok, *end_tok;
6447 int toklen;
6448 int has_exception_propagation =
76a01679 6449 is_runtime_sym_defined (raise_sym_name, 1);
4c4b4cd2
PH
6450
6451 *break_on_exceptionp = 1;
6452
6453 tok = arg + 9;
6454 while (*tok == ' ' || *tok == '\t')
6455 tok += 1;
6456
6457 end_tok = tok;
6458
6459 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
6460 end_tok += 1;
6461
6462 toklen = end_tok - tok;
6463
6464 arg = (char *) xmalloc (sizeof (longest_exception_template) + toklen);
6465 make_cleanup (xfree, arg);
6466 if (toklen == 0)
6467 {
76a01679
JB
6468 if (has_exception_propagation)
6469 sprintf (arg, "'%s'", raise_sym_name);
6470 else
6471 error_breakpoint_runtime_sym_not_found ("exception");
4c4b4cd2
PH
6472 }
6473 else if (strncmp (tok, "unhandled", toklen) == 0)
6474 {
76a01679
JB
6475 if (is_runtime_sym_defined (raise_unhandled_sym_name, 1))
6476 sprintf (arg, "'%s'", raise_unhandled_sym_name);
6477 else
6478 error_breakpoint_runtime_sym_not_found ("exception");
4c4b4cd2 6479
76a01679 6480 *break_on_exceptionp = 2;
4c4b4cd2
PH
6481 }
6482 else
6483 {
76a01679
JB
6484 if (is_runtime_sym_defined (raise_sym_name, 0))
6485 sprintf (arg, "'%s' if long_integer(e) = long_integer(&%.*s)",
6486 raise_sym_name, toklen, tok);
6487 else
6488 error_breakpoint_runtime_sym_not_found ("specific exception");
4c4b4cd2
PH
6489 }
6490 }
6491 else if (current_language->la_language == language_ada
6492 && strncmp (arg, "assert", 6) == 0
6493 && (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
6494 {
6495 char *tok = arg + 6;
6496
6497 if (!is_runtime_sym_defined (raise_assert_sym_name, 1))
76a01679 6498 error_breakpoint_runtime_sym_not_found ("failed assertion");
4c4b4cd2
PH
6499
6500 *break_on_exceptionp = 3;
6501
6502 arg =
6503 (char *) xmalloc (sizeof (raise_assert_sym_name) + strlen (tok) + 2);
6504 make_cleanup (xfree, arg);
6505 sprintf (arg, "'%s'%s", raise_assert_sym_name, tok);
6506 }
14f9c5c9
AS
6507 return arg;
6508}
96d887e8 6509#endif
14f9c5c9 6510\f
4c4b4cd2 6511 /* Field Access */
14f9c5c9
AS
6512
6513/* True if field number FIELD_NUM in struct or union type TYPE is supposed
4c4b4cd2 6514 to be invisible to users. */
14f9c5c9
AS
6515
6516int
ebf56fd3 6517ada_is_ignored_field (struct type *type, int field_num)
14f9c5c9
AS
6518{
6519 if (field_num < 0 || field_num > TYPE_NFIELDS (type))
6520 return 1;
d2e4a39e 6521 else
14f9c5c9 6522 {
d2e4a39e 6523 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9 6524 return (name == NULL
4c4b4cd2 6525 || (name[0] == '_' && strncmp (name, "_parent", 7) != 0));
14f9c5c9
AS
6526 }
6527}
6528
4c4b4cd2
PH
6529/* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6530 pointer or reference type whose ultimate target has a tag field. */
14f9c5c9
AS
6531
6532int
4c4b4cd2 6533ada_is_tagged_type (struct type *type, int refok)
14f9c5c9 6534{
4c4b4cd2
PH
6535 return (ada_lookup_struct_elt_type (type, "_tag", refok, 1, NULL) != NULL);
6536}
14f9c5c9 6537
4c4b4cd2
PH
6538/* True iff TYPE represents the type of X'Tag */
6539
6540int
6541ada_is_tag_type (struct type *type)
6542{
76a01679 6543 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_PTR)
4c4b4cd2 6544 return 0;
76a01679
JB
6545 else
6546 {
6547 const char *name = ada_type_name (TYPE_TARGET_TYPE (type));
6548 return (name != NULL
6549 && strcmp (name, "ada__tags__dispatch_table") == 0);
6550 }
14f9c5c9
AS
6551}
6552
4c4b4cd2 6553/* The type of the tag on VAL. */
14f9c5c9 6554
d2e4a39e
AS
6555struct type *
6556ada_tag_type (struct value *val)
14f9c5c9 6557{
4c4b4cd2 6558 return ada_lookup_struct_elt_type (VALUE_TYPE (val), "_tag", 1, 0, NULL);
14f9c5c9
AS
6559}
6560
4c4b4cd2 6561/* The value of the tag on VAL. */
14f9c5c9 6562
d2e4a39e
AS
6563struct value *
6564ada_value_tag (struct value *val)
14f9c5c9
AS
6565{
6566 return ada_value_struct_elt (val, "_tag", "record");
6567}
6568
4c4b4cd2
PH
6569/* The value of the tag on the object of type TYPE whose contents are
6570 saved at VALADDR, if it is non-null, or is at memory address
6571 ADDRESS. */
6572
6573static struct value *
6574value_tag_from_contents_and_address (struct type *type, char *valaddr,
76a01679 6575 CORE_ADDR address)
4c4b4cd2
PH
6576{
6577 int tag_byte_offset, dummy1, dummy2;
6578 struct type *tag_type;
6579 if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset,
76a01679 6580 &dummy1, &dummy2))
4c4b4cd2
PH
6581 {
6582 char *valaddr1 = (valaddr == NULL) ? NULL : valaddr + tag_byte_offset;
6583 CORE_ADDR address1 = (address == 0) ? 0 : address + tag_byte_offset;
6584
6585 return value_from_contents_and_address (tag_type, valaddr1, address1);
6586 }
6587 return NULL;
6588}
6589
6590static struct type *
6591type_from_tag (struct value *tag)
6592{
6593 const char *type_name = ada_tag_name (tag);
6594 if (type_name != NULL)
6595 return ada_find_any_type (ada_encode (type_name));
6596 return NULL;
6597}
6598
76a01679
JB
6599struct tag_args
6600{
4c4b4cd2
PH
6601 struct value *tag;
6602 char *name;
6603};
6604
6605/* Wrapper function used by ada_tag_name. Given a struct tag_args*
6606 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
6607 The value stored in ARGS->name is valid until the next call to
6608 ada_tag_name_1. */
6609
6610static int
6611ada_tag_name_1 (void *args0)
6612{
6613 struct tag_args *args = (struct tag_args *) args0;
6614 static char name[1024];
76a01679 6615 char *p;
4c4b4cd2
PH
6616 struct value *val;
6617 args->name = NULL;
6618 val = ada_value_struct_elt (args->tag, "tsd", NULL);
6619 if (val == NULL)
6620 return 0;
6621 val = ada_value_struct_elt (val, "expanded_name", NULL);
6622 if (val == NULL)
6623 return 0;
6624 read_memory_string (value_as_address (val), name, sizeof (name) - 1);
6625 for (p = name; *p != '\0'; p += 1)
6626 if (isalpha (*p))
6627 *p = tolower (*p);
6628 args->name = name;
6629 return 0;
6630}
6631
6632/* The type name of the dynamic type denoted by the 'tag value TAG, as
6633 * a C string. */
6634
6635const char *
6636ada_tag_name (struct value *tag)
6637{
6638 struct tag_args args;
76a01679 6639 if (!ada_is_tag_type (VALUE_TYPE (tag)))
4c4b4cd2 6640 return NULL;
76a01679 6641 args.tag = tag;
4c4b4cd2
PH
6642 args.name = NULL;
6643 catch_errors (ada_tag_name_1, &args, NULL, RETURN_MASK_ALL);
6644 return args.name;
6645}
6646
6647/* The parent type of TYPE, or NULL if none. */
14f9c5c9 6648
d2e4a39e 6649struct type *
ebf56fd3 6650ada_parent_type (struct type *type)
14f9c5c9
AS
6651{
6652 int i;
6653
6654 CHECK_TYPEDEF (type);
6655
6656 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
6657 return NULL;
6658
6659 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
6660 if (ada_is_parent_field (type, i))
6661 return check_typedef (TYPE_FIELD_TYPE (type, i));
6662
6663 return NULL;
6664}
6665
4c4b4cd2
PH
6666/* True iff field number FIELD_NUM of structure type TYPE contains the
6667 parent-type (inherited) fields of a derived type. Assumes TYPE is
6668 a structure type with at least FIELD_NUM+1 fields. */
14f9c5c9
AS
6669
6670int
ebf56fd3 6671ada_is_parent_field (struct type *type, int field_num)
14f9c5c9 6672{
d2e4a39e 6673 const char *name = TYPE_FIELD_NAME (check_typedef (type), field_num);
4c4b4cd2
PH
6674 return (name != NULL
6675 && (strncmp (name, "PARENT", 6) == 0
6676 || strncmp (name, "_parent", 7) == 0));
14f9c5c9
AS
6677}
6678
4c4b4cd2 6679/* True iff field number FIELD_NUM of structure type TYPE is a
14f9c5c9 6680 transparent wrapper field (which should be silently traversed when doing
4c4b4cd2 6681 field selection and flattened when printing). Assumes TYPE is a
14f9c5c9 6682 structure type with at least FIELD_NUM+1 fields. Such fields are always
4c4b4cd2 6683 structures. */
14f9c5c9
AS
6684
6685int
ebf56fd3 6686ada_is_wrapper_field (struct type *type, int field_num)
14f9c5c9 6687{
d2e4a39e
AS
6688 const char *name = TYPE_FIELD_NAME (type, field_num);
6689 return (name != NULL
4c4b4cd2
PH
6690 && (strncmp (name, "PARENT", 6) == 0
6691 || strcmp (name, "REP") == 0
6692 || strncmp (name, "_parent", 7) == 0
6693 || name[0] == 'S' || name[0] == 'R' || name[0] == 'O'));
14f9c5c9
AS
6694}
6695
4c4b4cd2
PH
6696/* True iff field number FIELD_NUM of structure or union type TYPE
6697 is a variant wrapper. Assumes TYPE is a structure type with at least
6698 FIELD_NUM+1 fields. */
14f9c5c9
AS
6699
6700int
ebf56fd3 6701ada_is_variant_part (struct type *type, int field_num)
14f9c5c9 6702{
d2e4a39e 6703 struct type *field_type = TYPE_FIELD_TYPE (type, field_num);
14f9c5c9 6704 return (TYPE_CODE (field_type) == TYPE_CODE_UNION
4c4b4cd2
PH
6705 || (is_dynamic_field (type, field_num)
6706 && TYPE_CODE (TYPE_TARGET_TYPE (field_type)) ==
6707 TYPE_CODE_UNION));
14f9c5c9
AS
6708}
6709
6710/* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
4c4b4cd2 6711 whose discriminants are contained in the record type OUTER_TYPE,
14f9c5c9
AS
6712 returns the type of the controlling discriminant for the variant. */
6713
d2e4a39e 6714struct type *
ebf56fd3 6715ada_variant_discrim_type (struct type *var_type, struct type *outer_type)
14f9c5c9 6716{
d2e4a39e 6717 char *name = ada_variant_discrim_name (var_type);
76a01679 6718 struct type *type =
4c4b4cd2 6719 ada_lookup_struct_elt_type (outer_type, name, 1, 1, NULL);
14f9c5c9
AS
6720 if (type == NULL)
6721 return builtin_type_int;
6722 else
6723 return type;
6724}
6725
4c4b4cd2 6726/* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
14f9c5c9 6727 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
4c4b4cd2 6728 represents a 'when others' clause; otherwise 0. */
14f9c5c9
AS
6729
6730int
ebf56fd3 6731ada_is_others_clause (struct type *type, int field_num)
14f9c5c9 6732{
d2e4a39e 6733 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6734 return (name != NULL && name[0] == 'O');
6735}
6736
6737/* Assuming that TYPE0 is the type of the variant part of a record,
4c4b4cd2
PH
6738 returns the name of the discriminant controlling the variant.
6739 The value is valid until the next call to ada_variant_discrim_name. */
14f9c5c9 6740
d2e4a39e 6741char *
ebf56fd3 6742ada_variant_discrim_name (struct type *type0)
14f9c5c9 6743{
d2e4a39e 6744 static char *result = NULL;
14f9c5c9 6745 static size_t result_len = 0;
d2e4a39e
AS
6746 struct type *type;
6747 const char *name;
6748 const char *discrim_end;
6749 const char *discrim_start;
14f9c5c9
AS
6750
6751 if (TYPE_CODE (type0) == TYPE_CODE_PTR)
6752 type = TYPE_TARGET_TYPE (type0);
6753 else
6754 type = type0;
6755
6756 name = ada_type_name (type);
6757
6758 if (name == NULL || name[0] == '\000')
6759 return "";
6760
6761 for (discrim_end = name + strlen (name) - 6; discrim_end != name;
6762 discrim_end -= 1)
6763 {
4c4b4cd2
PH
6764 if (strncmp (discrim_end, "___XVN", 6) == 0)
6765 break;
14f9c5c9
AS
6766 }
6767 if (discrim_end == name)
6768 return "";
6769
d2e4a39e 6770 for (discrim_start = discrim_end; discrim_start != name + 3;
14f9c5c9
AS
6771 discrim_start -= 1)
6772 {
d2e4a39e 6773 if (discrim_start == name + 1)
4c4b4cd2 6774 return "";
76a01679 6775 if ((discrim_start > name + 3
4c4b4cd2
PH
6776 && strncmp (discrim_start - 3, "___", 3) == 0)
6777 || discrim_start[-1] == '.')
6778 break;
14f9c5c9
AS
6779 }
6780
6781 GROW_VECT (result, result_len, discrim_end - discrim_start + 1);
6782 strncpy (result, discrim_start, discrim_end - discrim_start);
d2e4a39e 6783 result[discrim_end - discrim_start] = '\0';
14f9c5c9
AS
6784 return result;
6785}
6786
4c4b4cd2
PH
6787/* Scan STR for a subtype-encoded number, beginning at position K.
6788 Put the position of the character just past the number scanned in
6789 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6790 Return 1 if there was a valid number at the given position, and 0
6791 otherwise. A "subtype-encoded" number consists of the absolute value
6792 in decimal, followed by the letter 'm' to indicate a negative number.
6793 Assumes 0m does not occur. */
14f9c5c9
AS
6794
6795int
d2e4a39e 6796ada_scan_number (const char str[], int k, LONGEST * R, int *new_k)
14f9c5c9
AS
6797{
6798 ULONGEST RU;
6799
d2e4a39e 6800 if (!isdigit (str[k]))
14f9c5c9
AS
6801 return 0;
6802
4c4b4cd2 6803 /* Do it the hard way so as not to make any assumption about
14f9c5c9 6804 the relationship of unsigned long (%lu scan format code) and
4c4b4cd2 6805 LONGEST. */
14f9c5c9
AS
6806 RU = 0;
6807 while (isdigit (str[k]))
6808 {
d2e4a39e 6809 RU = RU * 10 + (str[k] - '0');
14f9c5c9
AS
6810 k += 1;
6811 }
6812
d2e4a39e 6813 if (str[k] == 'm')
14f9c5c9
AS
6814 {
6815 if (R != NULL)
4c4b4cd2 6816 *R = (-(LONGEST) (RU - 1)) - 1;
14f9c5c9
AS
6817 k += 1;
6818 }
6819 else if (R != NULL)
6820 *R = (LONGEST) RU;
6821
4c4b4cd2 6822 /* NOTE on the above: Technically, C does not say what the results of
14f9c5c9
AS
6823 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6824 number representable as a LONGEST (although either would probably work
6825 in most implementations). When RU>0, the locution in the then branch
4c4b4cd2 6826 above is always equivalent to the negative of RU. */
14f9c5c9
AS
6827
6828 if (new_k != NULL)
6829 *new_k = k;
6830 return 1;
6831}
6832
4c4b4cd2
PH
6833/* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6834 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6835 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
14f9c5c9 6836
d2e4a39e 6837int
ebf56fd3 6838ada_in_variant (LONGEST val, struct type *type, int field_num)
14f9c5c9 6839{
d2e4a39e 6840 const char *name = TYPE_FIELD_NAME (type, field_num);
14f9c5c9
AS
6841 int p;
6842
6843 p = 0;
6844 while (1)
6845 {
d2e4a39e 6846 switch (name[p])
4c4b4cd2
PH
6847 {
6848 case '\0':
6849 return 0;
6850 case 'S':
6851 {
6852 LONGEST W;
6853 if (!ada_scan_number (name, p + 1, &W, &p))
6854 return 0;
6855 if (val == W)
6856 return 1;
6857 break;
6858 }
6859 case 'R':
6860 {
6861 LONGEST L, U;
6862 if (!ada_scan_number (name, p + 1, &L, &p)
6863 || name[p] != 'T' || !ada_scan_number (name, p + 1, &U, &p))
6864 return 0;
6865 if (val >= L && val <= U)
6866 return 1;
6867 break;
6868 }
6869 case 'O':
6870 return 1;
6871 default:
6872 return 0;
6873 }
6874 }
6875}
6876
6877/* FIXME: Lots of redundancy below. Try to consolidate. */
6878
6879/* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6880 ARG_TYPE, extract and return the value of one of its (non-static)
6881 fields. FIELDNO says which field. Differs from value_primitive_field
6882 only in that it can handle packed values of arbitrary type. */
14f9c5c9 6883
4c4b4cd2 6884static struct value *
d2e4a39e 6885ada_value_primitive_field (struct value *arg1, int offset, int fieldno,
4c4b4cd2 6886 struct type *arg_type)
14f9c5c9 6887{
14f9c5c9
AS
6888 struct type *type;
6889
6890 CHECK_TYPEDEF (arg_type);
6891 type = TYPE_FIELD_TYPE (arg_type, fieldno);
6892
4c4b4cd2 6893 /* Handle packed fields. */
14f9c5c9
AS
6894
6895 if (TYPE_FIELD_BITSIZE (arg_type, fieldno) != 0)
6896 {
6897 int bit_pos = TYPE_FIELD_BITPOS (arg_type, fieldno);
6898 int bit_size = TYPE_FIELD_BITSIZE (arg_type, fieldno);
d2e4a39e 6899
14f9c5c9 6900 return ada_value_primitive_packed_val (arg1, VALUE_CONTENTS (arg1),
4c4b4cd2
PH
6901 offset + bit_pos / 8,
6902 bit_pos % 8, bit_size, type);
14f9c5c9
AS
6903 }
6904 else
6905 return value_primitive_field (arg1, offset, fieldno, arg_type);
6906}
6907
4c4b4cd2
PH
6908/* Find field with name NAME in object of type TYPE. If found, return 1
6909 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
6910 OFFSET + the byte offset of the field within an object of that type,
6911 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
6912 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
6913 Looks inside wrappers for the field. Returns 0 if field not
6914 found. */
6915static int
76a01679
JB
6916find_struct_field (char *name, struct type *type, int offset,
6917 struct type **field_type_p,
6918 int *byte_offset_p, int *bit_offset_p, int *bit_size_p)
4c4b4cd2
PH
6919{
6920 int i;
6921
6922 CHECK_TYPEDEF (type);
6923 *field_type_p = NULL;
6924 *byte_offset_p = *bit_offset_p = *bit_size_p = 0;
76a01679 6925
4c4b4cd2
PH
6926 for (i = TYPE_NFIELDS (type) - 1; i >= 0; i -= 1)
6927 {
6928 int bit_pos = TYPE_FIELD_BITPOS (type, i);
6929 int fld_offset = offset + bit_pos / 8;
6930 char *t_field_name = TYPE_FIELD_NAME (type, i);
76a01679 6931
4c4b4cd2
PH
6932 if (t_field_name == NULL)
6933 continue;
6934
6935 else if (field_name_match (t_field_name, name))
76a01679
JB
6936 {
6937 int bit_size = TYPE_FIELD_BITSIZE (type, i);
6938 *field_type_p = TYPE_FIELD_TYPE (type, i);
6939 *byte_offset_p = fld_offset;
6940 *bit_offset_p = bit_pos % 8;
6941 *bit_size_p = bit_size;
6942 return 1;
6943 }
4c4b4cd2
PH
6944 else if (ada_is_wrapper_field (type, i))
6945 {
76a01679
JB
6946 if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset,
6947 field_type_p, byte_offset_p, bit_offset_p,
6948 bit_size_p))
6949 return 1;
6950 }
4c4b4cd2
PH
6951 else if (ada_is_variant_part (type, i))
6952 {
6953 int j;
6954 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
6955
6956 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
6957 {
76a01679
JB
6958 if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j),
6959 fld_offset
6960 + TYPE_FIELD_BITPOS (field_type, j) / 8,
6961 field_type_p, byte_offset_p,
6962 bit_offset_p, bit_size_p))
6963 return 1;
4c4b4cd2
PH
6964 }
6965 }
6966 }
6967 return 0;
6968}
6969
6970
14f9c5c9 6971
4c4b4cd2 6972/* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
14f9c5c9
AS
6973 and search in it assuming it has (class) type TYPE.
6974 If found, return value, else return NULL.
6975
4c4b4cd2 6976 Searches recursively through wrapper fields (e.g., '_parent'). */
14f9c5c9 6977
4c4b4cd2 6978static struct value *
d2e4a39e 6979ada_search_struct_field (char *name, struct value *arg, int offset,
4c4b4cd2 6980 struct type *type)
14f9c5c9
AS
6981{
6982 int i;
6983 CHECK_TYPEDEF (type);
6984
d2e4a39e 6985 for (i = TYPE_NFIELDS (type) - 1; i >= 0; i -= 1)
14f9c5c9
AS
6986 {
6987 char *t_field_name = TYPE_FIELD_NAME (type, i);
6988
6989 if (t_field_name == NULL)
4c4b4cd2 6990 continue;
14f9c5c9
AS
6991
6992 else if (field_name_match (t_field_name, name))
4c4b4cd2 6993 return ada_value_primitive_field (arg, offset, i, type);
14f9c5c9
AS
6994
6995 else if (ada_is_wrapper_field (type, i))
4c4b4cd2 6996 {
76a01679
JB
6997 struct value *v = ada_search_struct_field (name, arg,
6998 offset +
6999 TYPE_FIELD_BITPOS (type,
7000 i) /
7001 8,
7002 TYPE_FIELD_TYPE (type,
7003 i));
4c4b4cd2
PH
7004 if (v != NULL)
7005 return v;
7006 }
14f9c5c9
AS
7007
7008 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7009 {
7010 int j;
7011 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
7012 int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8;
7013
7014 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7015 {
76a01679
JB
7016 struct value *v = ada_search_struct_field (name, arg,
7017 var_offset
7018 +
7019 TYPE_FIELD_BITPOS
7020 (field_type, j) / 8,
7021 TYPE_FIELD_TYPE
7022 (field_type, j));
4c4b4cd2
PH
7023 if (v != NULL)
7024 return v;
7025 }
7026 }
14f9c5c9
AS
7027 }
7028 return NULL;
7029}
d2e4a39e 7030
4c4b4cd2
PH
7031/* Given ARG, a value of type (pointer or reference to a)*
7032 structure/union, extract the component named NAME from the ultimate
7033 target structure/union and return it as a value with its
7034 appropriate type. If ARG is a pointer or reference and the field
7035 is not packed, returns a reference to the field, otherwise the
7036 value of the field (an lvalue if ARG is an lvalue).
14f9c5c9 7037
4c4b4cd2
PH
7038 The routine searches for NAME among all members of the structure itself
7039 and (recursively) among all members of any wrapper members
14f9c5c9
AS
7040 (e.g., '_parent').
7041
4c4b4cd2
PH
7042 ERR is a name (for use in error messages) that identifies the class
7043 of entity that ARG is supposed to be. ERR may be null, indicating
7044 that on error, the function simply returns NULL, and does not
7045 throw an error. (FIXME: True only if ARG is a pointer or reference
7046 at the moment). */
14f9c5c9 7047
d2e4a39e 7048struct value *
ebf56fd3 7049ada_value_struct_elt (struct value *arg, char *name, char *err)
14f9c5c9 7050{
4c4b4cd2 7051 struct type *t, *t1;
d2e4a39e 7052 struct value *v;
14f9c5c9 7053
4c4b4cd2
PH
7054 v = NULL;
7055 t1 = t = check_typedef (VALUE_TYPE (arg));
7056 if (TYPE_CODE (t) == TYPE_CODE_REF)
7057 {
7058 t1 = TYPE_TARGET_TYPE (t);
7059 if (t1 == NULL)
76a01679
JB
7060 {
7061 if (err == NULL)
7062 return NULL;
7063 else
7064 error ("Bad value type in a %s.", err);
7065 }
4c4b4cd2
PH
7066 CHECK_TYPEDEF (t1);
7067 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7068 {
7069 COERCE_REF (arg);
7070 t = t1;
7071 }
4c4b4cd2 7072 }
14f9c5c9 7073
4c4b4cd2
PH
7074 while (TYPE_CODE (t) == TYPE_CODE_PTR)
7075 {
7076 t1 = TYPE_TARGET_TYPE (t);
7077 if (t1 == NULL)
76a01679
JB
7078 {
7079 if (err == NULL)
7080 return NULL;
7081 else
7082 error ("Bad value type in a %s.", err);
7083 }
4c4b4cd2
PH
7084 CHECK_TYPEDEF (t1);
7085 if (TYPE_CODE (t1) == TYPE_CODE_PTR)
76a01679
JB
7086 {
7087 arg = value_ind (arg);
7088 t = t1;
7089 }
4c4b4cd2 7090 else
76a01679 7091 break;
4c4b4cd2 7092 }
14f9c5c9 7093
4c4b4cd2 7094 if (TYPE_CODE (t1) != TYPE_CODE_STRUCT && TYPE_CODE (t1) != TYPE_CODE_UNION)
14f9c5c9 7095 {
4c4b4cd2 7096 if (err == NULL)
76a01679 7097 return NULL;
4c4b4cd2 7098 else
76a01679
JB
7099 error ("Attempt to extract a component of a value that is not a %s.",
7100 err);
14f9c5c9
AS
7101 }
7102
4c4b4cd2
PH
7103 if (t1 == t)
7104 v = ada_search_struct_field (name, arg, 0, t);
7105 else
7106 {
7107 int bit_offset, bit_size, byte_offset;
7108 struct type *field_type;
7109 CORE_ADDR address;
7110
76a01679
JB
7111 if (TYPE_CODE (t) == TYPE_CODE_PTR)
7112 address = value_as_address (arg);
4c4b4cd2 7113 else
76a01679 7114 address = unpack_pointer (t, VALUE_CONTENTS (arg));
14f9c5c9 7115
4c4b4cd2 7116 t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL);
76a01679
JB
7117 if (find_struct_field (name, t1, 0,
7118 &field_type, &byte_offset, &bit_offset,
7119 &bit_size))
7120 {
7121 if (bit_size != 0)
7122 {
7123 arg = ada_value_ind (arg);
7124 v = ada_value_primitive_packed_val (arg, NULL, byte_offset,
7125 bit_offset, bit_size,
7126 field_type);
7127 }
7128 else
7129 v = value_from_pointer (lookup_reference_type (field_type),
7130 address + byte_offset);
7131 }
7132 }
7133
4c4b4cd2 7134 if (v == NULL && err != NULL)
14f9c5c9
AS
7135 error ("There is no member named %s.", name);
7136
7137 return v;
7138}
7139
7140/* Given a type TYPE, look up the type of the component of type named NAME.
4c4b4cd2
PH
7141 If DISPP is non-null, add its byte displacement from the beginning of a
7142 structure (pointed to by a value) of type TYPE to *DISPP (does not
14f9c5c9
AS
7143 work for packed fields).
7144
7145 Matches any field whose name has NAME as a prefix, possibly
4c4b4cd2 7146 followed by "___".
14f9c5c9 7147
4c4b4cd2
PH
7148 TYPE can be either a struct or union. If REFOK, TYPE may also
7149 be a (pointer or reference)+ to a struct or union, and the
7150 ultimate target type will be searched.
14f9c5c9
AS
7151
7152 Looks recursively into variant clauses and parent types.
7153
4c4b4cd2
PH
7154 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7155 TYPE is not a type of the right kind. */
14f9c5c9 7156
4c4b4cd2 7157static struct type *
76a01679
JB
7158ada_lookup_struct_elt_type (struct type *type, char *name, int refok,
7159 int noerr, int *dispp)
14f9c5c9
AS
7160{
7161 int i;
7162
7163 if (name == NULL)
7164 goto BadName;
7165
76a01679 7166 if (refok && type != NULL)
4c4b4cd2
PH
7167 while (1)
7168 {
76a01679
JB
7169 CHECK_TYPEDEF (type);
7170 if (TYPE_CODE (type) != TYPE_CODE_PTR
7171 && TYPE_CODE (type) != TYPE_CODE_REF)
7172 break;
7173 type = TYPE_TARGET_TYPE (type);
4c4b4cd2 7174 }
14f9c5c9 7175
76a01679 7176 if (type == NULL
1265e4aa
JB
7177 || (TYPE_CODE (type) != TYPE_CODE_STRUCT
7178 && TYPE_CODE (type) != TYPE_CODE_UNION))
14f9c5c9 7179 {
4c4b4cd2 7180 if (noerr)
76a01679 7181 return NULL;
4c4b4cd2 7182 else
76a01679
JB
7183 {
7184 target_terminal_ours ();
7185 gdb_flush (gdb_stdout);
7186 fprintf_unfiltered (gdb_stderr, "Type ");
7187 if (type == NULL)
7188 fprintf_unfiltered (gdb_stderr, "(null)");
7189 else
7190 type_print (type, "", gdb_stderr, -1);
7191 error (" is not a structure or union type");
7192 }
14f9c5c9
AS
7193 }
7194
7195 type = to_static_fixed_type (type);
7196
7197 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
7198 {
7199 char *t_field_name = TYPE_FIELD_NAME (type, i);
7200 struct type *t;
7201 int disp;
d2e4a39e 7202
14f9c5c9 7203 if (t_field_name == NULL)
4c4b4cd2 7204 continue;
14f9c5c9
AS
7205
7206 else if (field_name_match (t_field_name, name))
4c4b4cd2
PH
7207 {
7208 if (dispp != NULL)
7209 *dispp += TYPE_FIELD_BITPOS (type, i) / 8;
7210 return check_typedef (TYPE_FIELD_TYPE (type, i));
7211 }
14f9c5c9
AS
7212
7213 else if (ada_is_wrapper_field (type, i))
4c4b4cd2
PH
7214 {
7215 disp = 0;
7216 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type, i), name,
7217 0, 1, &disp);
7218 if (t != NULL)
7219 {
7220 if (dispp != NULL)
7221 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7222 return t;
7223 }
7224 }
14f9c5c9
AS
7225
7226 else if (ada_is_variant_part (type, i))
4c4b4cd2
PH
7227 {
7228 int j;
7229 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, i));
7230
7231 for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1)
7232 {
7233 disp = 0;
7234 t = ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type, j),
7235 name, 0, 1, &disp);
7236 if (t != NULL)
7237 {
7238 if (dispp != NULL)
7239 *dispp += disp + TYPE_FIELD_BITPOS (type, i) / 8;
7240 return t;
7241 }
7242 }
7243 }
14f9c5c9
AS
7244
7245 }
7246
7247BadName:
d2e4a39e 7248 if (!noerr)
14f9c5c9
AS
7249 {
7250 target_terminal_ours ();
7251 gdb_flush (gdb_stdout);
7252 fprintf_unfiltered (gdb_stderr, "Type ");
7253 type_print (type, "", gdb_stderr, -1);
7254 fprintf_unfiltered (gdb_stderr, " has no component named ");
7255 error ("%s", name == NULL ? "<null>" : name);
7256 }
7257
7258 return NULL;
7259}
7260
7261/* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7262 within a value of type OUTER_TYPE that is stored in GDB at
4c4b4cd2
PH
7263 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7264 numbering from 0) is applicable. Returns -1 if none are. */
14f9c5c9 7265
d2e4a39e 7266int
ebf56fd3 7267ada_which_variant_applies (struct type *var_type, struct type *outer_type,
4c4b4cd2 7268 char *outer_valaddr)
14f9c5c9
AS
7269{
7270 int others_clause;
7271 int i;
7272 int disp;
d2e4a39e
AS
7273 struct type *discrim_type;
7274 char *discrim_name = ada_variant_discrim_name (var_type);
14f9c5c9
AS
7275 LONGEST discrim_val;
7276
7277 disp = 0;
d2e4a39e 7278 discrim_type =
4c4b4cd2 7279 ada_lookup_struct_elt_type (outer_type, discrim_name, 1, 1, &disp);
14f9c5c9
AS
7280 if (discrim_type == NULL)
7281 return -1;
7282 discrim_val = unpack_long (discrim_type, outer_valaddr + disp);
7283
7284 others_clause = -1;
7285 for (i = 0; i < TYPE_NFIELDS (var_type); i += 1)
7286 {
7287 if (ada_is_others_clause (var_type, i))
4c4b4cd2 7288 others_clause = i;
14f9c5c9 7289 else if (ada_in_variant (discrim_val, var_type, i))
4c4b4cd2 7290 return i;
14f9c5c9
AS
7291 }
7292
7293 return others_clause;
7294}
d2e4a39e 7295\f
14f9c5c9
AS
7296
7297
4c4b4cd2 7298 /* Dynamic-Sized Records */
14f9c5c9
AS
7299
7300/* Strategy: The type ostensibly attached to a value with dynamic size
7301 (i.e., a size that is not statically recorded in the debugging
7302 data) does not accurately reflect the size or layout of the value.
7303 Our strategy is to convert these values to values with accurate,
4c4b4cd2 7304 conventional types that are constructed on the fly. */
14f9c5c9
AS
7305
7306/* There is a subtle and tricky problem here. In general, we cannot
7307 determine the size of dynamic records without its data. However,
7308 the 'struct value' data structure, which GDB uses to represent
7309 quantities in the inferior process (the target), requires the size
7310 of the type at the time of its allocation in order to reserve space
7311 for GDB's internal copy of the data. That's why the
7312 'to_fixed_xxx_type' routines take (target) addresses as parameters,
4c4b4cd2 7313 rather than struct value*s.
14f9c5c9
AS
7314
7315 However, GDB's internal history variables ($1, $2, etc.) are
7316 struct value*s containing internal copies of the data that are not, in
7317 general, the same as the data at their corresponding addresses in
7318 the target. Fortunately, the types we give to these values are all
7319 conventional, fixed-size types (as per the strategy described
7320 above), so that we don't usually have to perform the
7321 'to_fixed_xxx_type' conversions to look at their values.
7322 Unfortunately, there is one exception: if one of the internal
7323 history variables is an array whose elements are unconstrained
7324 records, then we will need to create distinct fixed types for each
7325 element selected. */
7326
7327/* The upshot of all of this is that many routines take a (type, host
7328 address, target address) triple as arguments to represent a value.
7329 The host address, if non-null, is supposed to contain an internal
7330 copy of the relevant data; otherwise, the program is to consult the
4c4b4cd2 7331 target at the target address. */
14f9c5c9
AS
7332
7333/* Assuming that VAL0 represents a pointer value, the result of
7334 dereferencing it. Differs from value_ind in its treatment of
4c4b4cd2 7335 dynamic-sized types. */
14f9c5c9 7336
d2e4a39e
AS
7337struct value *
7338ada_value_ind (struct value *val0)
14f9c5c9 7339{
d2e4a39e 7340 struct value *val = unwrap_value (value_ind (val0));
4c4b4cd2 7341 return ada_to_fixed_value (val);
14f9c5c9
AS
7342}
7343
7344/* The value resulting from dereferencing any "reference to"
4c4b4cd2
PH
7345 qualifiers on VAL0. */
7346
d2e4a39e
AS
7347static struct value *
7348ada_coerce_ref (struct value *val0)
7349{
7350 if (TYPE_CODE (VALUE_TYPE (val0)) == TYPE_CODE_REF)
7351 {
7352 struct value *val = val0;
7353 COERCE_REF (val);
7354 val = unwrap_value (val);
4c4b4cd2 7355 return ada_to_fixed_value (val);
d2e4a39e
AS
7356 }
7357 else
14f9c5c9
AS
7358 return val0;
7359}
7360
7361/* Return OFF rounded upward if necessary to a multiple of
4c4b4cd2 7362 ALIGNMENT (a power of 2). */
14f9c5c9
AS
7363
7364static unsigned int
ebf56fd3 7365align_value (unsigned int off, unsigned int alignment)
14f9c5c9
AS
7366{
7367 return (off + alignment - 1) & ~(alignment - 1);
7368}
7369
4c4b4cd2 7370/* Return the bit alignment required for field #F of template type TYPE. */
14f9c5c9
AS
7371
7372static unsigned int
ebf56fd3 7373field_alignment (struct type *type, int f)
14f9c5c9 7374{
d2e4a39e 7375 const char *name = TYPE_FIELD_NAME (type, f);
14f9c5c9
AS
7376 int len = (name == NULL) ? 0 : strlen (name);
7377 int align_offset;
7378
4c4b4cd2
PH
7379 if (!isdigit (name[len - 1]))
7380 return 1;
14f9c5c9 7381
d2e4a39e 7382 if (isdigit (name[len - 2]))
14f9c5c9
AS
7383 align_offset = len - 2;
7384 else
7385 align_offset = len - 1;
7386
4c4b4cd2 7387 if (align_offset < 7 || strncmp ("___XV", name + align_offset - 6, 5) != 0)
14f9c5c9
AS
7388 return TARGET_CHAR_BIT;
7389
4c4b4cd2
PH
7390 return atoi (name + align_offset) * TARGET_CHAR_BIT;
7391}
7392
7393/* Find a symbol named NAME. Ignores ambiguity. */
7394
7395struct symbol *
7396ada_find_any_symbol (const char *name)
7397{
7398 struct symbol *sym;
7399
7400 sym = standard_lookup (name, get_selected_block (NULL), VAR_DOMAIN);
7401 if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
7402 return sym;
7403
7404 sym = standard_lookup (name, NULL, STRUCT_DOMAIN);
7405 return sym;
14f9c5c9
AS
7406}
7407
7408/* Find a type named NAME. Ignores ambiguity. */
4c4b4cd2 7409
d2e4a39e 7410struct type *
ebf56fd3 7411ada_find_any_type (const char *name)
14f9c5c9 7412{
4c4b4cd2 7413 struct symbol *sym = ada_find_any_symbol (name);
14f9c5c9 7414
14f9c5c9
AS
7415 if (sym != NULL)
7416 return SYMBOL_TYPE (sym);
7417
7418 return NULL;
7419}
7420
4c4b4cd2
PH
7421/* Given a symbol NAME and its associated BLOCK, search all symbols
7422 for its ___XR counterpart, which is the ``renaming'' symbol
7423 associated to NAME. Return this symbol if found, return
7424 NULL otherwise. */
7425
7426struct symbol *
7427ada_find_renaming_symbol (const char *name, struct block *block)
7428{
7429 const struct symbol *function_sym = block_function (block);
7430 char *rename;
7431
7432 if (function_sym != NULL)
7433 {
7434 /* If the symbol is defined inside a function, NAME is not fully
7435 qualified. This means we need to prepend the function name
7436 as well as adding the ``___XR'' suffix to build the name of
7437 the associated renaming symbol. */
7438 char *function_name = SYMBOL_LINKAGE_NAME (function_sym);
7439 const int function_name_len = strlen (function_name);
76a01679
JB
7440 const int rename_len = function_name_len + 2 /* "__" */
7441 + strlen (name) + 6 /* "___XR\0" */ ;
4c4b4cd2
PH
7442
7443 /* Library-level functions are a special case, as GNAT adds
7444 a ``_ada_'' prefix to the function name to avoid namespace
7445 pollution. However, the renaming symbol themselves do not
7446 have this prefix, so we need to skip this prefix if present. */
7447 if (function_name_len > 5 /* "_ada_" */
7448 && strstr (function_name, "_ada_") == function_name)
7449 function_name = function_name + 5;
7450
7451 rename = (char *) alloca (rename_len * sizeof (char));
7452 sprintf (rename, "%s__%s___XR", function_name, name);
7453 }
7454 else
7455 {
7456 const int rename_len = strlen (name) + 6;
7457 rename = (char *) alloca (rename_len * sizeof (char));
7458 sprintf (rename, "%s___XR", name);
7459 }
7460
7461 return ada_find_any_symbol (rename);
7462}
7463
14f9c5c9 7464/* Because of GNAT encoding conventions, several GDB symbols may match a
4c4b4cd2 7465 given type name. If the type denoted by TYPE0 is to be preferred to
14f9c5c9 7466 that of TYPE1 for purposes of type printing, return non-zero;
4c4b4cd2
PH
7467 otherwise return 0. */
7468
14f9c5c9 7469int
d2e4a39e 7470ada_prefer_type (struct type *type0, struct type *type1)
14f9c5c9
AS
7471{
7472 if (type1 == NULL)
7473 return 1;
7474 else if (type0 == NULL)
7475 return 0;
7476 else if (TYPE_CODE (type1) == TYPE_CODE_VOID)
7477 return 1;
7478 else if (TYPE_CODE (type0) == TYPE_CODE_VOID)
7479 return 0;
4c4b4cd2
PH
7480 else if (TYPE_NAME (type1) == NULL && TYPE_NAME (type0) != NULL)
7481 return 1;
14f9c5c9
AS
7482 else if (ada_is_packed_array_type (type0))
7483 return 1;
4c4b4cd2
PH
7484 else if (ada_is_array_descriptor_type (type0)
7485 && !ada_is_array_descriptor_type (type1))
14f9c5c9 7486 return 1;
d2e4a39e 7487 else if (ada_renaming_type (type0) != NULL
4c4b4cd2 7488 && ada_renaming_type (type1) == NULL)
14f9c5c9
AS
7489 return 1;
7490 return 0;
7491}
7492
7493/* The name of TYPE, which is either its TYPE_NAME, or, if that is
4c4b4cd2
PH
7494 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7495
d2e4a39e
AS
7496char *
7497ada_type_name (struct type *type)
14f9c5c9 7498{
d2e4a39e 7499 if (type == NULL)
14f9c5c9
AS
7500 return NULL;
7501 else if (TYPE_NAME (type) != NULL)
7502 return TYPE_NAME (type);
7503 else
7504 return TYPE_TAG_NAME (type);
7505}
7506
7507/* Find a parallel type to TYPE whose name is formed by appending
4c4b4cd2 7508 SUFFIX to the name of TYPE. */
14f9c5c9 7509
d2e4a39e 7510struct type *
ebf56fd3 7511ada_find_parallel_type (struct type *type, const char *suffix)
14f9c5c9 7512{
d2e4a39e 7513 static char *name;
14f9c5c9 7514 static size_t name_len = 0;
14f9c5c9 7515 int len;
d2e4a39e
AS
7516 char *typename = ada_type_name (type);
7517
14f9c5c9
AS
7518 if (typename == NULL)
7519 return NULL;
7520
7521 len = strlen (typename);
7522
d2e4a39e 7523 GROW_VECT (name, name_len, len + strlen (suffix) + 1);
14f9c5c9
AS
7524
7525 strcpy (name, typename);
7526 strcpy (name + len, suffix);
7527
7528 return ada_find_any_type (name);
7529}
7530
7531
7532/* If TYPE is a variable-size record type, return the corresponding template
4c4b4cd2 7533 type describing its fields. Otherwise, return NULL. */
14f9c5c9 7534
d2e4a39e
AS
7535static struct type *
7536dynamic_template_type (struct type *type)
14f9c5c9
AS
7537{
7538 CHECK_TYPEDEF (type);
7539
7540 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT
d2e4a39e 7541 || ada_type_name (type) == NULL)
14f9c5c9 7542 return NULL;
d2e4a39e 7543 else
14f9c5c9
AS
7544 {
7545 int len = strlen (ada_type_name (type));
4c4b4cd2
PH
7546 if (len > 6 && strcmp (ada_type_name (type) + len - 6, "___XVE") == 0)
7547 return type;
14f9c5c9 7548 else
4c4b4cd2 7549 return ada_find_parallel_type (type, "___XVE");
14f9c5c9
AS
7550 }
7551}
7552
7553/* Assuming that TEMPL_TYPE is a union or struct type, returns
4c4b4cd2 7554 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
14f9c5c9 7555
d2e4a39e
AS
7556static int
7557is_dynamic_field (struct type *templ_type, int field_num)
14f9c5c9
AS
7558{
7559 const char *name = TYPE_FIELD_NAME (templ_type, field_num);
d2e4a39e 7560 return name != NULL
14f9c5c9
AS
7561 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type, field_num)) == TYPE_CODE_PTR
7562 && strstr (name, "___XVL") != NULL;
7563}
7564
4c4b4cd2
PH
7565/* The index of the variant field of TYPE, or -1 if TYPE does not
7566 represent a variant record type. */
14f9c5c9 7567
d2e4a39e 7568static int
4c4b4cd2 7569variant_field_index (struct type *type)
14f9c5c9
AS
7570{
7571 int f;
7572
4c4b4cd2
PH
7573 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_STRUCT)
7574 return -1;
7575
7576 for (f = 0; f < TYPE_NFIELDS (type); f += 1)
7577 {
7578 if (ada_is_variant_part (type, f))
7579 return f;
7580 }
7581 return -1;
14f9c5c9
AS
7582}
7583
4c4b4cd2
PH
7584/* A record type with no fields. */
7585
d2e4a39e
AS
7586static struct type *
7587empty_record (struct objfile *objfile)
14f9c5c9 7588{
d2e4a39e 7589 struct type *type = alloc_type (objfile);
14f9c5c9
AS
7590 TYPE_CODE (type) = TYPE_CODE_STRUCT;
7591 TYPE_NFIELDS (type) = 0;
7592 TYPE_FIELDS (type) = NULL;
7593 TYPE_NAME (type) = "<empty>";
7594 TYPE_TAG_NAME (type) = NULL;
7595 TYPE_FLAGS (type) = 0;
7596 TYPE_LENGTH (type) = 0;
7597 return type;
7598}
7599
7600/* An ordinary record type (with fixed-length fields) that describes
4c4b4cd2
PH
7601 the value of type TYPE at VALADDR or ADDRESS (see comments at
7602 the beginning of this section) VAL according to GNAT conventions.
7603 DVAL0 should describe the (portion of a) record that contains any
14f9c5c9
AS
7604 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
7605 an outer-level type (i.e., as opposed to a branch of a variant.) A
7606 variant field (unless unchecked) is replaced by a particular branch
4c4b4cd2 7607 of the variant.
14f9c5c9 7608
4c4b4cd2
PH
7609 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7610 length are not statically known are discarded. As a consequence,
7611 VALADDR, ADDRESS and DVAL0 are ignored.
7612
7613 NOTE: Limitations: For now, we assume that dynamic fields and
7614 variants occupy whole numbers of bytes. However, they need not be
7615 byte-aligned. */
7616
7617struct type *
7618ada_template_to_fixed_record_type_1 (struct type *type, char *valaddr,
7619 CORE_ADDR address, struct value *dval0,
7620 int keep_dynamic_fields)
14f9c5c9 7621{
d2e4a39e
AS
7622 struct value *mark = value_mark ();
7623 struct value *dval;
7624 struct type *rtype;
14f9c5c9 7625 int nfields, bit_len;
4c4b4cd2 7626 int variant_field;
14f9c5c9 7627 long off;
4c4b4cd2 7628 int fld_bit_len, bit_incr;
14f9c5c9
AS
7629 int f;
7630
4c4b4cd2
PH
7631 /* Compute the number of fields in this record type that are going
7632 to be processed: unless keep_dynamic_fields, this includes only
7633 fields whose position and length are static will be processed. */
7634 if (keep_dynamic_fields)
7635 nfields = TYPE_NFIELDS (type);
7636 else
7637 {
7638 nfields = 0;
76a01679 7639 while (nfields < TYPE_NFIELDS (type)
4c4b4cd2
PH
7640 && !ada_is_variant_part (type, nfields)
7641 && !is_dynamic_field (type, nfields))
7642 nfields++;
7643 }
7644
14f9c5c9
AS
7645 rtype = alloc_type (TYPE_OBJFILE (type));
7646 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
7647 INIT_CPLUS_SPECIFIC (rtype);
7648 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e 7649 TYPE_FIELDS (rtype) = (struct field *)
14f9c5c9
AS
7650 TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7651 memset (TYPE_FIELDS (rtype), 0, sizeof (struct field) * nfields);
7652 TYPE_NAME (rtype) = ada_type_name (type);
7653 TYPE_TAG_NAME (rtype) = NULL;
4c4b4cd2 7654 TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9 7655
d2e4a39e
AS
7656 off = 0;
7657 bit_len = 0;
4c4b4cd2
PH
7658 variant_field = -1;
7659
14f9c5c9
AS
7660 for (f = 0; f < nfields; f += 1)
7661 {
d2e4a39e 7662 off =
4c4b4cd2
PH
7663 align_value (off,
7664 field_alignment (type, f)) + TYPE_FIELD_BITPOS (type, f);
14f9c5c9 7665 TYPE_FIELD_BITPOS (rtype, f) = off;
d2e4a39e 7666 TYPE_FIELD_BITSIZE (rtype, f) = 0;
14f9c5c9 7667
d2e4a39e 7668 if (ada_is_variant_part (type, f))
4c4b4cd2
PH
7669 {
7670 variant_field = f;
7671 fld_bit_len = bit_incr = 0;
7672 }
14f9c5c9 7673 else if (is_dynamic_field (type, f))
4c4b4cd2
PH
7674 {
7675 if (dval0 == NULL)
7676 dval = value_from_contents_and_address (rtype, valaddr, address);
7677 else
7678 dval = dval0;
7679
7680 TYPE_FIELD_TYPE (rtype, f) =
7681 ada_to_fixed_type
7682 (ada_get_base_type
7683 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, f))),
7684 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7685 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7686 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7687 bit_incr = fld_bit_len =
7688 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, f)) * TARGET_CHAR_BIT;
7689 }
14f9c5c9 7690 else
4c4b4cd2
PH
7691 {
7692 TYPE_FIELD_TYPE (rtype, f) = TYPE_FIELD_TYPE (type, f);
7693 TYPE_FIELD_NAME (rtype, f) = TYPE_FIELD_NAME (type, f);
7694 if (TYPE_FIELD_BITSIZE (type, f) > 0)
7695 bit_incr = fld_bit_len =
7696 TYPE_FIELD_BITSIZE (rtype, f) = TYPE_FIELD_BITSIZE (type, f);
7697 else
7698 bit_incr = fld_bit_len =
7699 TYPE_LENGTH (TYPE_FIELD_TYPE (type, f)) * TARGET_CHAR_BIT;
7700 }
14f9c5c9 7701 if (off + fld_bit_len > bit_len)
4c4b4cd2 7702 bit_len = off + fld_bit_len;
14f9c5c9 7703 off += bit_incr;
4c4b4cd2
PH
7704 TYPE_LENGTH (rtype) =
7705 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
14f9c5c9 7706 }
4c4b4cd2
PH
7707
7708 /* We handle the variant part, if any, at the end because of certain
7709 odd cases in which it is re-ordered so as NOT the last field of
7710 the record. This can happen in the presence of representation
7711 clauses. */
7712 if (variant_field >= 0)
7713 {
7714 struct type *branch_type;
7715
7716 off = TYPE_FIELD_BITPOS (rtype, variant_field);
7717
7718 if (dval0 == NULL)
7719 dval = value_from_contents_and_address (rtype, valaddr, address);
7720 else
7721 dval = dval0;
7722
7723 branch_type =
7724 to_fixed_variant_branch_type
7725 (TYPE_FIELD_TYPE (type, variant_field),
7726 cond_offset_host (valaddr, off / TARGET_CHAR_BIT),
7727 cond_offset_target (address, off / TARGET_CHAR_BIT), dval);
7728 if (branch_type == NULL)
7729 {
7730 for (f = variant_field + 1; f < TYPE_NFIELDS (rtype); f += 1)
7731 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
7732 TYPE_NFIELDS (rtype) -= 1;
7733 }
7734 else
7735 {
7736 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7737 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7738 fld_bit_len =
7739 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype, variant_field)) *
7740 TARGET_CHAR_BIT;
7741 if (off + fld_bit_len > bit_len)
7742 bit_len = off + fld_bit_len;
7743 TYPE_LENGTH (rtype) =
7744 align_value (bit_len, TARGET_CHAR_BIT) / TARGET_CHAR_BIT;
7745 }
7746 }
7747
14f9c5c9
AS
7748 TYPE_LENGTH (rtype) = align_value (TYPE_LENGTH (rtype), TYPE_LENGTH (type));
7749
7750 value_free_to_mark (mark);
d2e4a39e 7751 if (TYPE_LENGTH (rtype) > varsize_limit)
14f9c5c9
AS
7752 error ("record type with dynamic size is larger than varsize-limit");
7753 return rtype;
7754}
7755
4c4b4cd2
PH
7756/* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7757 of 1. */
14f9c5c9 7758
d2e4a39e 7759static struct type *
4c4b4cd2
PH
7760template_to_fixed_record_type (struct type *type, char *valaddr,
7761 CORE_ADDR address, struct value *dval0)
7762{
7763 return ada_template_to_fixed_record_type_1 (type, valaddr,
7764 address, dval0, 1);
7765}
7766
7767/* An ordinary record type in which ___XVL-convention fields and
7768 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7769 static approximations, containing all possible fields. Uses
7770 no runtime values. Useless for use in values, but that's OK,
7771 since the results are used only for type determinations. Works on both
7772 structs and unions. Representation note: to save space, we memorize
7773 the result of this function in the TYPE_TARGET_TYPE of the
7774 template type. */
7775
7776static struct type *
7777template_to_static_fixed_type (struct type *type0)
14f9c5c9
AS
7778{
7779 struct type *type;
7780 int nfields;
7781 int f;
7782
4c4b4cd2
PH
7783 if (TYPE_TARGET_TYPE (type0) != NULL)
7784 return TYPE_TARGET_TYPE (type0);
7785
7786 nfields = TYPE_NFIELDS (type0);
7787 type = type0;
14f9c5c9
AS
7788
7789 for (f = 0; f < nfields; f += 1)
7790 {
4c4b4cd2
PH
7791 struct type *field_type = CHECK_TYPEDEF (TYPE_FIELD_TYPE (type0, f));
7792 struct type *new_type;
14f9c5c9 7793
4c4b4cd2
PH
7794 if (is_dynamic_field (type0, f))
7795 new_type = to_static_fixed_type (TYPE_TARGET_TYPE (field_type));
14f9c5c9 7796 else
4c4b4cd2
PH
7797 new_type = to_static_fixed_type (field_type);
7798 if (type == type0 && new_type != field_type)
7799 {
7800 TYPE_TARGET_TYPE (type0) = type = alloc_type (TYPE_OBJFILE (type0));
7801 TYPE_CODE (type) = TYPE_CODE (type0);
7802 INIT_CPLUS_SPECIFIC (type);
7803 TYPE_NFIELDS (type) = nfields;
7804 TYPE_FIELDS (type) = (struct field *)
7805 TYPE_ALLOC (type, nfields * sizeof (struct field));
7806 memcpy (TYPE_FIELDS (type), TYPE_FIELDS (type0),
7807 sizeof (struct field) * nfields);
7808 TYPE_NAME (type) = ada_type_name (type0);
7809 TYPE_TAG_NAME (type) = NULL;
7810 TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE;
7811 TYPE_LENGTH (type) = 0;
7812 }
7813 TYPE_FIELD_TYPE (type, f) = new_type;
7814 TYPE_FIELD_NAME (type, f) = TYPE_FIELD_NAME (type0, f);
14f9c5c9 7815 }
14f9c5c9
AS
7816 return type;
7817}
7818
4c4b4cd2
PH
7819/* Given an object of type TYPE whose contents are at VALADDR and
7820 whose address in memory is ADDRESS, returns a revision of TYPE --
7821 a non-dynamic-sized record with a variant part -- in which
7822 the variant part is replaced with the appropriate branch. Looks
7823 for discriminant values in DVAL0, which can be NULL if the record
7824 contains the necessary discriminant values. */
7825
d2e4a39e
AS
7826static struct type *
7827to_record_with_fixed_variant_part (struct type *type, char *valaddr,
4c4b4cd2 7828 CORE_ADDR address, struct value *dval0)
14f9c5c9 7829{
d2e4a39e 7830 struct value *mark = value_mark ();
4c4b4cd2 7831 struct value *dval;
d2e4a39e 7832 struct type *rtype;
14f9c5c9
AS
7833 struct type *branch_type;
7834 int nfields = TYPE_NFIELDS (type);
4c4b4cd2 7835 int variant_field = variant_field_index (type);
14f9c5c9 7836
4c4b4cd2 7837 if (variant_field == -1)
14f9c5c9
AS
7838 return type;
7839
4c4b4cd2
PH
7840 if (dval0 == NULL)
7841 dval = value_from_contents_and_address (type, valaddr, address);
7842 else
7843 dval = dval0;
7844
14f9c5c9
AS
7845 rtype = alloc_type (TYPE_OBJFILE (type));
7846 TYPE_CODE (rtype) = TYPE_CODE_STRUCT;
4c4b4cd2
PH
7847 INIT_CPLUS_SPECIFIC (rtype);
7848 TYPE_NFIELDS (rtype) = nfields;
d2e4a39e
AS
7849 TYPE_FIELDS (rtype) =
7850 (struct field *) TYPE_ALLOC (rtype, nfields * sizeof (struct field));
7851 memcpy (TYPE_FIELDS (rtype), TYPE_FIELDS (type),
4c4b4cd2 7852 sizeof (struct field) * nfields);
14f9c5c9
AS
7853 TYPE_NAME (rtype) = ada_type_name (type);
7854 TYPE_TAG_NAME (rtype) = NULL;
4c4b4cd2 7855 TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9
AS
7856 TYPE_LENGTH (rtype) = TYPE_LENGTH (type);
7857
4c4b4cd2
PH
7858 branch_type = to_fixed_variant_branch_type
7859 (TYPE_FIELD_TYPE (type, variant_field),
d2e4a39e 7860 cond_offset_host (valaddr,
4c4b4cd2
PH
7861 TYPE_FIELD_BITPOS (type, variant_field)
7862 / TARGET_CHAR_BIT),
d2e4a39e 7863 cond_offset_target (address,
4c4b4cd2
PH
7864 TYPE_FIELD_BITPOS (type, variant_field)
7865 / TARGET_CHAR_BIT), dval);
d2e4a39e 7866 if (branch_type == NULL)
14f9c5c9 7867 {
4c4b4cd2
PH
7868 int f;
7869 for (f = variant_field + 1; f < nfields; f += 1)
7870 TYPE_FIELDS (rtype)[f - 1] = TYPE_FIELDS (rtype)[f];
14f9c5c9 7871 TYPE_NFIELDS (rtype) -= 1;
14f9c5c9
AS
7872 }
7873 else
7874 {
4c4b4cd2
PH
7875 TYPE_FIELD_TYPE (rtype, variant_field) = branch_type;
7876 TYPE_FIELD_NAME (rtype, variant_field) = "S";
7877 TYPE_FIELD_BITSIZE (rtype, variant_field) = 0;
14f9c5c9 7878 TYPE_LENGTH (rtype) += TYPE_LENGTH (branch_type);
14f9c5c9 7879 }
4c4b4cd2 7880 TYPE_LENGTH (rtype) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type, variant_field));
d2e4a39e 7881
4c4b4cd2 7882 value_free_to_mark (mark);
14f9c5c9
AS
7883 return rtype;
7884}
7885
7886/* An ordinary record type (with fixed-length fields) that describes
7887 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7888 beginning of this section]. Any necessary discriminants' values
4c4b4cd2
PH
7889 should be in DVAL, a record value; it may be NULL if the object
7890 at ADDR itself contains any necessary discriminant values.
7891 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7892 values from the record are needed. Except in the case that DVAL,
7893 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7894 unchecked) is replaced by a particular branch of the variant.
7895
7896 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7897 is questionable and may be removed. It can arise during the
7898 processing of an unconstrained-array-of-record type where all the
7899 variant branches have exactly the same size. This is because in
7900 such cases, the compiler does not bother to use the XVS convention
7901 when encoding the record. I am currently dubious of this
7902 shortcut and suspect the compiler should be altered. FIXME. */
14f9c5c9 7903
d2e4a39e 7904static struct type *
4c4b4cd2
PH
7905to_fixed_record_type (struct type *type0, char *valaddr,
7906 CORE_ADDR address, struct value *dval)
14f9c5c9 7907{
d2e4a39e 7908 struct type *templ_type;
14f9c5c9 7909
4c4b4cd2
PH
7910 if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
7911 return type0;
7912
d2e4a39e 7913 templ_type = dynamic_template_type (type0);
14f9c5c9
AS
7914
7915 if (templ_type != NULL)
7916 return template_to_fixed_record_type (templ_type, valaddr, address, dval);
4c4b4cd2
PH
7917 else if (variant_field_index (type0) >= 0)
7918 {
7919 if (dval == NULL && valaddr == NULL && address == 0)
7920 return type0;
7921 return to_record_with_fixed_variant_part (type0, valaddr, address,
7922 dval);
7923 }
14f9c5c9
AS
7924 else
7925 {
4c4b4cd2 7926 TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9
AS
7927 return type0;
7928 }
7929
7930}
7931
7932/* An ordinary record type (with fixed-length fields) that describes
7933 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7934 union type. Any necessary discriminants' values should be in DVAL,
7935 a record value. That is, this routine selects the appropriate
7936 branch of the union at ADDR according to the discriminant value
4c4b4cd2 7937 indicated in the union's type name. */
14f9c5c9 7938
d2e4a39e
AS
7939static struct type *
7940to_fixed_variant_branch_type (struct type *var_type0, char *valaddr,
4c4b4cd2 7941 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
7942{
7943 int which;
d2e4a39e
AS
7944 struct type *templ_type;
7945 struct type *var_type;
14f9c5c9
AS
7946
7947 if (TYPE_CODE (var_type0) == TYPE_CODE_PTR)
7948 var_type = TYPE_TARGET_TYPE (var_type0);
d2e4a39e 7949 else
14f9c5c9
AS
7950 var_type = var_type0;
7951
7952 templ_type = ada_find_parallel_type (var_type, "___XVU");
7953
7954 if (templ_type != NULL)
7955 var_type = templ_type;
7956
d2e4a39e
AS
7957 which =
7958 ada_which_variant_applies (var_type,
4c4b4cd2 7959 VALUE_TYPE (dval), VALUE_CONTENTS (dval));
14f9c5c9
AS
7960
7961 if (which < 0)
7962 return empty_record (TYPE_OBJFILE (var_type));
7963 else if (is_dynamic_field (var_type, which))
4c4b4cd2 7964 return to_fixed_record_type
d2e4a39e
AS
7965 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type, which)),
7966 valaddr, address, dval);
4c4b4cd2 7967 else if (variant_field_index (TYPE_FIELD_TYPE (var_type, which)) >= 0)
d2e4a39e
AS
7968 return
7969 to_fixed_record_type
7970 (TYPE_FIELD_TYPE (var_type, which), valaddr, address, dval);
14f9c5c9
AS
7971 else
7972 return TYPE_FIELD_TYPE (var_type, which);
7973}
7974
7975/* Assuming that TYPE0 is an array type describing the type of a value
7976 at ADDR, and that DVAL describes a record containing any
7977 discriminants used in TYPE0, returns a type for the value that
7978 contains no dynamic components (that is, no components whose sizes
7979 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7980 true, gives an error message if the resulting type's size is over
4c4b4cd2 7981 varsize_limit. */
14f9c5c9 7982
d2e4a39e
AS
7983static struct type *
7984to_fixed_array_type (struct type *type0, struct value *dval,
4c4b4cd2 7985 int ignore_too_big)
14f9c5c9 7986{
d2e4a39e
AS
7987 struct type *index_type_desc;
7988 struct type *result;
14f9c5c9 7989
4c4b4cd2
PH
7990 if (ada_is_packed_array_type (type0) /* revisit? */
7991 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
7992 return type0;
14f9c5c9
AS
7993
7994 index_type_desc = ada_find_parallel_type (type0, "___XA");
7995 if (index_type_desc == NULL)
7996 {
7997 struct type *elt_type0 = check_typedef (TYPE_TARGET_TYPE (type0));
7998 /* NOTE: elt_type---the fixed version of elt_type0---should never
4c4b4cd2
PH
7999 depend on the contents of the array in properly constructed
8000 debugging data. */
d2e4a39e 8001 struct type *elt_type = ada_to_fixed_type (elt_type0, 0, 0, dval);
14f9c5c9
AS
8002
8003 if (elt_type0 == elt_type)
4c4b4cd2 8004 result = type0;
14f9c5c9 8005 else
4c4b4cd2
PH
8006 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
8007 elt_type, TYPE_INDEX_TYPE (type0));
14f9c5c9
AS
8008 }
8009 else
8010 {
8011 int i;
8012 struct type *elt_type0;
8013
8014 elt_type0 = type0;
8015 for (i = TYPE_NFIELDS (index_type_desc); i > 0; i -= 1)
4c4b4cd2 8016 elt_type0 = TYPE_TARGET_TYPE (elt_type0);
14f9c5c9
AS
8017
8018 /* NOTE: result---the fixed version of elt_type0---should never
4c4b4cd2
PH
8019 depend on the contents of the array in properly constructed
8020 debugging data. */
d2e4a39e 8021 result = ada_to_fixed_type (check_typedef (elt_type0), 0, 0, dval);
14f9c5c9 8022 for (i = TYPE_NFIELDS (index_type_desc) - 1; i >= 0; i -= 1)
4c4b4cd2
PH
8023 {
8024 struct type *range_type =
8025 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc, i),
8026 dval, TYPE_OBJFILE (type0));
8027 result = create_array_type (alloc_type (TYPE_OBJFILE (type0)),
8028 result, range_type);
8029 }
d2e4a39e 8030 if (!ignore_too_big && TYPE_LENGTH (result) > varsize_limit)
4c4b4cd2 8031 error ("array type with dynamic size is larger than varsize-limit");
14f9c5c9
AS
8032 }
8033
4c4b4cd2 8034 TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE;
14f9c5c9 8035 return result;
d2e4a39e 8036}
14f9c5c9
AS
8037
8038
8039/* A standard type (containing no dynamically sized components)
8040 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8041 DVAL describes a record containing any discriminants used in TYPE0,
4c4b4cd2
PH
8042 and may be NULL if there are none, or if the object of type TYPE at
8043 ADDRESS or in VALADDR contains these discriminants. */
14f9c5c9 8044
d2e4a39e 8045struct type *
4c4b4cd2
PH
8046ada_to_fixed_type (struct type *type, char *valaddr,
8047 CORE_ADDR address, struct value *dval)
14f9c5c9
AS
8048{
8049 CHECK_TYPEDEF (type);
d2e4a39e
AS
8050 switch (TYPE_CODE (type))
8051 {
8052 default:
14f9c5c9 8053 return type;
d2e4a39e 8054 case TYPE_CODE_STRUCT:
4c4b4cd2 8055 {
76a01679
JB
8056 struct type *static_type = to_static_fixed_type (type);
8057 if (ada_is_tagged_type (static_type, 0))
8058 {
8059 struct type *real_type =
8060 type_from_tag (value_tag_from_contents_and_address (static_type,
8061 valaddr,
8062 address));
8063 if (real_type != NULL)
8064 type = real_type;
8065 }
8066 return to_fixed_record_type (type, valaddr, address, NULL);
4c4b4cd2 8067 }
d2e4a39e 8068 case TYPE_CODE_ARRAY:
4c4b4cd2 8069 return to_fixed_array_type (type, dval, 1);
d2e4a39e
AS
8070 case TYPE_CODE_UNION:
8071 if (dval == NULL)
4c4b4cd2 8072 return type;
d2e4a39e 8073 else
4c4b4cd2 8074 return to_fixed_variant_branch_type (type, valaddr, address, dval);
d2e4a39e 8075 }
14f9c5c9
AS
8076}
8077
8078/* A standard (static-sized) type corresponding as well as possible to
4c4b4cd2 8079 TYPE0, but based on no runtime data. */
14f9c5c9 8080
d2e4a39e
AS
8081static struct type *
8082to_static_fixed_type (struct type *type0)
14f9c5c9 8083{
d2e4a39e 8084 struct type *type;
14f9c5c9
AS
8085
8086 if (type0 == NULL)
8087 return NULL;
8088
4c4b4cd2
PH
8089 if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
8090 return type0;
8091
14f9c5c9 8092 CHECK_TYPEDEF (type0);
d2e4a39e 8093
14f9c5c9
AS
8094 switch (TYPE_CODE (type0))
8095 {
8096 default:
8097 return type0;
8098 case TYPE_CODE_STRUCT:
8099 type = dynamic_template_type (type0);
d2e4a39e 8100 if (type != NULL)
4c4b4cd2
PH
8101 return template_to_static_fixed_type (type);
8102 else
8103 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8104 case TYPE_CODE_UNION:
8105 type = ada_find_parallel_type (type0, "___XVU");
8106 if (type != NULL)
4c4b4cd2
PH
8107 return template_to_static_fixed_type (type);
8108 else
8109 return template_to_static_fixed_type (type0);
14f9c5c9
AS
8110 }
8111}
8112
4c4b4cd2
PH
8113/* A static approximation of TYPE with all type wrappers removed. */
8114
d2e4a39e
AS
8115static struct type *
8116static_unwrap_type (struct type *type)
14f9c5c9
AS
8117{
8118 if (ada_is_aligner_type (type))
8119 {
d2e4a39e 8120 struct type *type1 = TYPE_FIELD_TYPE (check_typedef (type), 0);
14f9c5c9 8121 if (ada_type_name (type1) == NULL)
4c4b4cd2 8122 TYPE_NAME (type1) = ada_type_name (type);
14f9c5c9
AS
8123
8124 return static_unwrap_type (type1);
8125 }
d2e4a39e 8126 else
14f9c5c9 8127 {
d2e4a39e
AS
8128 struct type *raw_real_type = ada_get_base_type (type);
8129 if (raw_real_type == type)
4c4b4cd2 8130 return type;
14f9c5c9 8131 else
4c4b4cd2 8132 return to_static_fixed_type (raw_real_type);
14f9c5c9
AS
8133 }
8134}
8135
8136/* In some cases, incomplete and private types require
4c4b4cd2 8137 cross-references that are not resolved as records (for example,
14f9c5c9
AS
8138 type Foo;
8139 type FooP is access Foo;
8140 V: FooP;
8141 type Foo is array ...;
4c4b4cd2 8142 ). In these cases, since there is no mechanism for producing
14f9c5c9
AS
8143 cross-references to such types, we instead substitute for FooP a
8144 stub enumeration type that is nowhere resolved, and whose tag is
4c4b4cd2 8145 the name of the actual type. Call these types "non-record stubs". */
14f9c5c9
AS
8146
8147/* A type equivalent to TYPE that is not a non-record stub, if one
4c4b4cd2
PH
8148 exists, otherwise TYPE. */
8149
d2e4a39e
AS
8150struct type *
8151ada_completed_type (struct type *type)
14f9c5c9
AS
8152{
8153 CHECK_TYPEDEF (type);
8154 if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM
8155 || (TYPE_FLAGS (type) & TYPE_FLAG_STUB) == 0
8156 || TYPE_TAG_NAME (type) == NULL)
8157 return type;
d2e4a39e 8158 else
14f9c5c9 8159 {
d2e4a39e
AS
8160 char *name = TYPE_TAG_NAME (type);
8161 struct type *type1 = ada_find_any_type (name);
14f9c5c9
AS
8162 return (type1 == NULL) ? type : type1;
8163 }
8164}
8165
8166/* A value representing the data at VALADDR/ADDRESS as described by
8167 type TYPE0, but with a standard (static-sized) type that correctly
8168 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8169 type, then return VAL0 [this feature is simply to avoid redundant
4c4b4cd2 8170 creation of struct values]. */
14f9c5c9 8171
4c4b4cd2
PH
8172static struct value *
8173ada_to_fixed_value_create (struct type *type0, CORE_ADDR address,
8174 struct value *val0)
14f9c5c9 8175{
4c4b4cd2 8176 struct type *type = ada_to_fixed_type (type0, 0, address, NULL);
14f9c5c9
AS
8177 if (type == type0 && val0 != NULL)
8178 return val0;
d2e4a39e 8179 else
4c4b4cd2
PH
8180 return value_from_contents_and_address (type, 0, address);
8181}
8182
8183/* A value representing VAL, but with a standard (static-sized) type
8184 that correctly describes it. Does not necessarily create a new
8185 value. */
8186
8187static struct value *
8188ada_to_fixed_value (struct value *val)
8189{
8190 return ada_to_fixed_value_create (VALUE_TYPE (val),
8191 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
8192 val);
14f9c5c9
AS
8193}
8194
4c4b4cd2
PH
8195/* If the PC is pointing inside a function prologue, then re-adjust it
8196 past this prologue. */
8197
8198static void
8199adjust_pc_past_prologue (CORE_ADDR *pc)
8200{
8201 struct symbol *func_sym = find_pc_function (*pc);
8202
8203 if (func_sym)
8204 {
76a01679
JB
8205 const struct symtab_and_line sal =
8206 find_function_start_sal (func_sym, 1);
4c4b4cd2
PH
8207
8208 if (*pc <= sal.pc)
8209 *pc = sal.pc;
8210 }
8211}
8212
8213/* A value representing VAL, but with a standard (static-sized) type
14f9c5c9
AS
8214 chosen to approximate the real type of VAL as well as possible, but
8215 without consulting any runtime values. For Ada dynamic-sized
4c4b4cd2 8216 types, therefore, the type of the result is likely to be inaccurate. */
14f9c5c9 8217
d2e4a39e
AS
8218struct value *
8219ada_to_static_fixed_value (struct value *val)
14f9c5c9 8220{
d2e4a39e 8221 struct type *type =
14f9c5c9
AS
8222 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val)));
8223 if (type == VALUE_TYPE (val))
8224 return val;
8225 else
4c4b4cd2 8226 return coerce_unspec_val_to_type (val, type);
14f9c5c9 8227}
d2e4a39e 8228\f
14f9c5c9 8229
14f9c5c9
AS
8230/* Attributes */
8231
4c4b4cd2
PH
8232/* Table mapping attribute numbers to names.
8233 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
14f9c5c9 8234
d2e4a39e 8235static const char *attribute_names[] = {
14f9c5c9
AS
8236 "<?>",
8237
d2e4a39e 8238 "first",
14f9c5c9
AS
8239 "last",
8240 "length",
8241 "image",
14f9c5c9
AS
8242 "max",
8243 "min",
4c4b4cd2
PH
8244 "modulus",
8245 "pos",
8246 "size",
8247 "tag",
14f9c5c9 8248 "val",
14f9c5c9
AS
8249 0
8250};
8251
d2e4a39e 8252const char *
4c4b4cd2 8253ada_attribute_name (enum exp_opcode n)
14f9c5c9 8254{
4c4b4cd2
PH
8255 if (n >= OP_ATR_FIRST && n <= (int) OP_ATR_VAL)
8256 return attribute_names[n - OP_ATR_FIRST + 1];
14f9c5c9
AS
8257 else
8258 return attribute_names[0];
8259}
8260
4c4b4cd2 8261/* Evaluate the 'POS attribute applied to ARG. */
14f9c5c9 8262
4c4b4cd2
PH
8263static LONGEST
8264pos_atr (struct value *arg)
14f9c5c9
AS
8265{
8266 struct type *type = VALUE_TYPE (arg);
8267
d2e4a39e 8268 if (!discrete_type_p (type))
14f9c5c9
AS
8269 error ("'POS only defined on discrete types");
8270
8271 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8272 {
8273 int i;
8274 LONGEST v = value_as_long (arg);
8275
d2e4a39e 8276 for (i = 0; i < TYPE_NFIELDS (type); i += 1)
4c4b4cd2
PH
8277 {
8278 if (v == TYPE_FIELD_BITPOS (type, i))
8279 return i;
8280 }
14f9c5c9
AS
8281 error ("enumeration value is invalid: can't find 'POS");
8282 }
8283 else
4c4b4cd2
PH
8284 return value_as_long (arg);
8285}
8286
8287static struct value *
8288value_pos_atr (struct value *arg)
8289{
8290 return value_from_longest (builtin_type_ada_int, pos_atr (arg));
14f9c5c9
AS
8291}
8292
4c4b4cd2 8293/* Evaluate the TYPE'VAL attribute applied to ARG. */
14f9c5c9 8294
d2e4a39e
AS
8295static struct value *
8296value_val_atr (struct type *type, struct value *arg)
14f9c5c9 8297{
d2e4a39e 8298 if (!discrete_type_p (type))
14f9c5c9 8299 error ("'VAL only defined on discrete types");
d2e4a39e 8300 if (!integer_type_p (VALUE_TYPE (arg)))
14f9c5c9
AS
8301 error ("'VAL requires integral argument");
8302
8303 if (TYPE_CODE (type) == TYPE_CODE_ENUM)
8304 {
8305 long pos = value_as_long (arg);
8306 if (pos < 0 || pos >= TYPE_NFIELDS (type))
4c4b4cd2 8307 error ("argument to 'VAL out of range");
d2e4a39e 8308 return value_from_longest (type, TYPE_FIELD_BITPOS (type, pos));
14f9c5c9
AS
8309 }
8310 else
8311 return value_from_longest (type, value_as_long (arg));
8312}
14f9c5c9 8313\f
d2e4a39e 8314
4c4b4cd2 8315 /* Evaluation */
14f9c5c9 8316
4c4b4cd2
PH
8317/* True if TYPE appears to be an Ada character type.
8318 [At the moment, this is true only for Character and Wide_Character;
8319 It is a heuristic test that could stand improvement]. */
14f9c5c9 8320
d2e4a39e
AS
8321int
8322ada_is_character_type (struct type *type)
14f9c5c9 8323{
d2e4a39e
AS
8324 const char *name = ada_type_name (type);
8325 return
14f9c5c9 8326 name != NULL
d2e4a39e 8327 && (TYPE_CODE (type) == TYPE_CODE_CHAR
4c4b4cd2
PH
8328 || TYPE_CODE (type) == TYPE_CODE_INT
8329 || TYPE_CODE (type) == TYPE_CODE_RANGE)
8330 && (strcmp (name, "character") == 0
8331 || strcmp (name, "wide_character") == 0
8332 || strcmp (name, "unsigned char") == 0);
14f9c5c9
AS
8333}
8334
4c4b4cd2 8335/* True if TYPE appears to be an Ada string type. */
14f9c5c9
AS
8336
8337int
ebf56fd3 8338ada_is_string_type (struct type *type)
14f9c5c9
AS
8339{
8340 CHECK_TYPEDEF (type);
d2e4a39e 8341 if (type != NULL
14f9c5c9 8342 && TYPE_CODE (type) != TYPE_CODE_PTR
76a01679
JB
8343 && (ada_is_simple_array_type (type)
8344 || ada_is_array_descriptor_type (type))
14f9c5c9
AS
8345 && ada_array_arity (type) == 1)
8346 {
8347 struct type *elttype = ada_array_element_type (type, 1);
8348
8349 return ada_is_character_type (elttype);
8350 }
d2e4a39e 8351 else
14f9c5c9
AS
8352 return 0;
8353}
8354
8355
8356/* True if TYPE is a struct type introduced by the compiler to force the
8357 alignment of a value. Such types have a single field with a
4c4b4cd2 8358 distinctive name. */
14f9c5c9
AS
8359
8360int
ebf56fd3 8361ada_is_aligner_type (struct type *type)
14f9c5c9
AS
8362{
8363 CHECK_TYPEDEF (type);
8364 return (TYPE_CODE (type) == TYPE_CODE_STRUCT
4c4b4cd2
PH
8365 && TYPE_NFIELDS (type) == 1
8366 && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
14f9c5c9
AS
8367}
8368
8369/* If there is an ___XVS-convention type parallel to SUBTYPE, return
4c4b4cd2 8370 the parallel type. */
14f9c5c9 8371
d2e4a39e
AS
8372struct type *
8373ada_get_base_type (struct type *raw_type)
14f9c5c9 8374{
d2e4a39e
AS
8375 struct type *real_type_namer;
8376 struct type *raw_real_type;
14f9c5c9
AS
8377
8378 if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
8379 return raw_type;
8380
8381 real_type_namer = ada_find_parallel_type (raw_type, "___XVS");
d2e4a39e 8382 if (real_type_namer == NULL
14f9c5c9
AS
8383 || TYPE_CODE (real_type_namer) != TYPE_CODE_STRUCT
8384 || TYPE_NFIELDS (real_type_namer) != 1)
8385 return raw_type;
8386
8387 raw_real_type = ada_find_any_type (TYPE_FIELD_NAME (real_type_namer, 0));
d2e4a39e 8388 if (raw_real_type == NULL)
14f9c5c9
AS
8389 return raw_type;
8390 else
8391 return raw_real_type;
d2e4a39e 8392}
14f9c5c9 8393
4c4b4cd2 8394/* The type of value designated by TYPE, with all aligners removed. */
14f9c5c9 8395
d2e4a39e
AS
8396struct type *
8397ada_aligned_type (struct type *type)
14f9c5c9
AS
8398{
8399 if (ada_is_aligner_type (type))
8400 return ada_aligned_type (TYPE_FIELD_TYPE (type, 0));
8401 else
8402 return ada_get_base_type (type);
8403}
8404
8405
8406/* The address of the aligned value in an object at address VALADDR
4c4b4cd2 8407 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
14f9c5c9 8408
d2e4a39e 8409char *
ebf56fd3 8410ada_aligned_value_addr (struct type *type, char *valaddr)
14f9c5c9 8411{
d2e4a39e 8412 if (ada_is_aligner_type (type))
14f9c5c9 8413 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
4c4b4cd2
PH
8414 valaddr +
8415 TYPE_FIELD_BITPOS (type,
8416 0) / TARGET_CHAR_BIT);
14f9c5c9
AS
8417 else
8418 return valaddr;
8419}
8420
4c4b4cd2
PH
8421
8422
14f9c5c9 8423/* The printed representation of an enumeration literal with encoded
4c4b4cd2 8424 name NAME. The value is good to the next call of ada_enum_name. */
d2e4a39e
AS
8425const char *
8426ada_enum_name (const char *name)
14f9c5c9 8427{
4c4b4cd2
PH
8428 static char *result;
8429 static size_t result_len = 0;
d2e4a39e 8430 char *tmp;
14f9c5c9 8431
4c4b4cd2
PH
8432 /* First, unqualify the enumeration name:
8433 1. Search for the last '.' character. If we find one, then skip
76a01679
JB
8434 all the preceeding characters, the unqualified name starts
8435 right after that dot.
4c4b4cd2 8436 2. Otherwise, we may be debugging on a target where the compiler
76a01679
JB
8437 translates dots into "__". Search forward for double underscores,
8438 but stop searching when we hit an overloading suffix, which is
8439 of the form "__" followed by digits. */
4c4b4cd2
PH
8440
8441 if ((tmp = strrchr (name, '.')) != NULL)
8442 name = tmp + 1;
8443 else
14f9c5c9 8444 {
4c4b4cd2
PH
8445 while ((tmp = strstr (name, "__")) != NULL)
8446 {
8447 if (isdigit (tmp[2]))
8448 break;
8449 else
8450 name = tmp + 2;
8451 }
14f9c5c9
AS
8452 }
8453
8454 if (name[0] == 'Q')
8455 {
14f9c5c9
AS
8456 int v;
8457 if (name[1] == 'U' || name[1] == 'W')
4c4b4cd2
PH
8458 {
8459 if (sscanf (name + 2, "%x", &v) != 1)
8460 return name;
8461 }
14f9c5c9 8462 else
4c4b4cd2 8463 return name;
14f9c5c9 8464
4c4b4cd2 8465 GROW_VECT (result, result_len, 16);
14f9c5c9 8466 if (isascii (v) && isprint (v))
4c4b4cd2 8467 sprintf (result, "'%c'", v);
14f9c5c9 8468 else if (name[1] == 'U')
4c4b4cd2 8469 sprintf (result, "[\"%02x\"]", v);
14f9c5c9 8470 else
4c4b4cd2 8471 sprintf (result, "[\"%04x\"]", v);
14f9c5c9
AS
8472
8473 return result;
8474 }
d2e4a39e 8475 else
4c4b4cd2
PH
8476 {
8477 if ((tmp = strstr (name, "__")) != NULL
8478 || (tmp = strstr (name, "$")) != NULL)
8479 {
8480 GROW_VECT (result, result_len, tmp - name + 1);
8481 strncpy (result, name, tmp - name);
8482 result[tmp - name] = '\0';
8483 return result;
8484 }
8485
8486 return name;
8487 }
14f9c5c9
AS
8488}
8489
d2e4a39e 8490static struct value *
ebf56fd3 8491evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
4c4b4cd2 8492 enum noside noside)
14f9c5c9 8493{
76a01679 8494 return (*exp->language_defn->la_exp_desc->evaluate_exp)
4c4b4cd2 8495 (expect_type, exp, pos, noside);
14f9c5c9
AS
8496}
8497
8498/* Evaluate the subexpression of EXP starting at *POS as for
8499 evaluate_type, updating *POS to point just past the evaluated
4c4b4cd2 8500 expression. */
14f9c5c9 8501
d2e4a39e
AS
8502static struct value *
8503evaluate_subexp_type (struct expression *exp, int *pos)
14f9c5c9 8504{
4c4b4cd2 8505 return (*exp->language_defn->la_exp_desc->evaluate_exp)
14f9c5c9
AS
8506 (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
8507}
8508
8509/* If VAL is wrapped in an aligner or subtype wrapper, return the
4c4b4cd2 8510 value it wraps. */
14f9c5c9 8511
d2e4a39e
AS
8512static struct value *
8513unwrap_value (struct value *val)
14f9c5c9 8514{
d2e4a39e 8515 struct type *type = check_typedef (VALUE_TYPE (val));
14f9c5c9
AS
8516 if (ada_is_aligner_type (type))
8517 {
d2e4a39e 8518 struct value *v = value_struct_elt (&val, NULL, "F",
4c4b4cd2 8519 NULL, "internal structure");
d2e4a39e 8520 struct type *val_type = check_typedef (VALUE_TYPE (v));
14f9c5c9 8521 if (ada_type_name (val_type) == NULL)
4c4b4cd2 8522 TYPE_NAME (val_type) = ada_type_name (type);
14f9c5c9
AS
8523
8524 return unwrap_value (v);
8525 }
d2e4a39e 8526 else
14f9c5c9 8527 {
d2e4a39e 8528 struct type *raw_real_type =
4c4b4cd2 8529 ada_completed_type (ada_get_base_type (type));
d2e4a39e 8530
14f9c5c9 8531 if (type == raw_real_type)
4c4b4cd2 8532 return val;
14f9c5c9 8533
d2e4a39e 8534 return
4c4b4cd2
PH
8535 coerce_unspec_val_to_type
8536 (val, ada_to_fixed_type (raw_real_type, 0,
8537 VALUE_ADDRESS (val) + VALUE_OFFSET (val),
8538 NULL));
14f9c5c9
AS
8539 }
8540}
d2e4a39e
AS
8541
8542static struct value *
8543cast_to_fixed (struct type *type, struct value *arg)
14f9c5c9
AS
8544{
8545 LONGEST val;
8546
8547 if (type == VALUE_TYPE (arg))
8548 return arg;
8549 else if (ada_is_fixed_point_type (VALUE_TYPE (arg)))
d2e4a39e 8550 val = ada_float_to_fixed (type,
4c4b4cd2
PH
8551 ada_fixed_to_float (VALUE_TYPE (arg),
8552 value_as_long (arg)));
d2e4a39e 8553 else
14f9c5c9 8554 {
d2e4a39e 8555 DOUBLEST argd =
4c4b4cd2 8556 value_as_double (value_cast (builtin_type_double, value_copy (arg)));
14f9c5c9
AS
8557 val = ada_float_to_fixed (type, argd);
8558 }
8559
8560 return value_from_longest (type, val);
8561}
8562
d2e4a39e
AS
8563static struct value *
8564cast_from_fixed_to_double (struct value *arg)
14f9c5c9
AS
8565{
8566 DOUBLEST val = ada_fixed_to_float (VALUE_TYPE (arg),
4c4b4cd2 8567 value_as_long (arg));
14f9c5c9
AS
8568 return value_from_double (builtin_type_double, val);
8569}
8570
4c4b4cd2
PH
8571/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8572 return the converted value. */
8573
d2e4a39e
AS
8574static struct value *
8575coerce_for_assign (struct type *type, struct value *val)
14f9c5c9 8576{
d2e4a39e 8577 struct type *type2 = VALUE_TYPE (val);
14f9c5c9
AS
8578 if (type == type2)
8579 return val;
8580
8581 CHECK_TYPEDEF (type2);
8582 CHECK_TYPEDEF (type);
8583
d2e4a39e
AS
8584 if (TYPE_CODE (type2) == TYPE_CODE_PTR
8585 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
14f9c5c9
AS
8586 {
8587 val = ada_value_ind (val);
8588 type2 = VALUE_TYPE (val);
8589 }
8590
d2e4a39e 8591 if (TYPE_CODE (type2) == TYPE_CODE_ARRAY
14f9c5c9
AS
8592 && TYPE_CODE (type) == TYPE_CODE_ARRAY)
8593 {
8594 if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
4c4b4cd2
PH
8595 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
8596 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
8597 error ("Incompatible types in assignment");
14f9c5c9
AS
8598 VALUE_TYPE (val) = type;
8599 }
d2e4a39e 8600 return val;
14f9c5c9
AS
8601}
8602
4c4b4cd2
PH
8603static struct value *
8604ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
8605{
8606 struct value *val;
8607 struct type *type1, *type2;
8608 LONGEST v, v1, v2;
8609
8610 COERCE_REF (arg1);
8611 COERCE_REF (arg2);
8612 type1 = base_type (check_typedef (VALUE_TYPE (arg1)));
8613 type2 = base_type (check_typedef (VALUE_TYPE (arg2)));
8614
76a01679
JB
8615 if (TYPE_CODE (type1) != TYPE_CODE_INT
8616 || TYPE_CODE (type2) != TYPE_CODE_INT)
4c4b4cd2
PH
8617 return value_binop (arg1, arg2, op);
8618
76a01679 8619 switch (op)
4c4b4cd2
PH
8620 {
8621 case BINOP_MOD:
8622 case BINOP_DIV:
8623 case BINOP_REM:
8624 break;
8625 default:
8626 return value_binop (arg1, arg2, op);
8627 }
8628
8629 v2 = value_as_long (arg2);
8630 if (v2 == 0)
8631 error ("second operand of %s must not be zero.", op_string (op));
8632
8633 if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
8634 return value_binop (arg1, arg2, op);
8635
8636 v1 = value_as_long (arg1);
8637 switch (op)
8638 {
8639 case BINOP_DIV:
8640 v = v1 / v2;
76a01679
JB
8641 if (!TRUNCATION_TOWARDS_ZERO && v1 * (v1 % v2) < 0)
8642 v += v > 0 ? -1 : 1;
4c4b4cd2
PH
8643 break;
8644 case BINOP_REM:
8645 v = v1 % v2;
76a01679
JB
8646 if (v * v1 < 0)
8647 v -= v2;
4c4b4cd2
PH
8648 break;
8649 default:
8650 /* Should not reach this point. */
8651 v = 0;
8652 }
8653
8654 val = allocate_value (type1);
8655 store_unsigned_integer (VALUE_CONTENTS_RAW (val),
76a01679 8656 TYPE_LENGTH (VALUE_TYPE (val)), v);
4c4b4cd2
PH
8657 return val;
8658}
8659
8660static int
8661ada_value_equal (struct value *arg1, struct value *arg2)
8662{
76a01679 8663 if (ada_is_direct_array_type (VALUE_TYPE (arg1))
4c4b4cd2
PH
8664 || ada_is_direct_array_type (VALUE_TYPE (arg2)))
8665 {
8666 arg1 = ada_coerce_to_simple_array (arg1);
8667 arg2 = ada_coerce_to_simple_array (arg2);
8668 if (TYPE_CODE (VALUE_TYPE (arg1)) != TYPE_CODE_ARRAY
76a01679
JB
8669 || TYPE_CODE (VALUE_TYPE (arg2)) != TYPE_CODE_ARRAY)
8670 error ("Attempt to compare array with non-array");
4c4b4cd2 8671 /* FIXME: The following works only for types whose
76a01679
JB
8672 representations use all bits (no padding or undefined bits)
8673 and do not have user-defined equality. */
8674 return
8675 TYPE_LENGTH (VALUE_TYPE (arg1)) == TYPE_LENGTH (VALUE_TYPE (arg2))
8676 && memcmp (VALUE_CONTENTS (arg1), VALUE_CONTENTS (arg2),
8677 TYPE_LENGTH (VALUE_TYPE (arg1))) == 0;
4c4b4cd2
PH
8678 }
8679 return value_equal (arg1, arg2);
8680}
8681
d2e4a39e 8682struct value *
ebf56fd3 8683ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
4c4b4cd2 8684 int *pos, enum noside noside)
14f9c5c9
AS
8685{
8686 enum exp_opcode op;
14f9c5c9
AS
8687 int tem, tem2, tem3;
8688 int pc;
8689 struct value *arg1 = NULL, *arg2 = NULL, *arg3;
8690 struct type *type;
8691 int nargs;
d2e4a39e 8692 struct value **argvec;
14f9c5c9 8693
d2e4a39e
AS
8694 pc = *pos;
8695 *pos += 1;
14f9c5c9
AS
8696 op = exp->elts[pc].opcode;
8697
d2e4a39e 8698 switch (op)
14f9c5c9
AS
8699 {
8700 default:
8701 *pos -= 1;
d2e4a39e 8702 return
4c4b4cd2
PH
8703 unwrap_value (evaluate_subexp_standard
8704 (expect_type, exp, pos, noside));
8705
8706 case OP_STRING:
8707 {
76a01679
JB
8708 struct value *result;
8709 *pos -= 1;
8710 result = evaluate_subexp_standard (expect_type, exp, pos, noside);
8711 /* The result type will have code OP_STRING, bashed there from
8712 OP_ARRAY. Bash it back. */
8713 if (TYPE_CODE (VALUE_TYPE (result)) == TYPE_CODE_STRING)
8714 TYPE_CODE (VALUE_TYPE (result)) = TYPE_CODE_ARRAY;
8715 return result;
4c4b4cd2 8716 }
14f9c5c9
AS
8717
8718 case UNOP_CAST:
8719 (*pos) += 2;
8720 type = exp->elts[pc + 1].type;
8721 arg1 = evaluate_subexp (type, exp, pos, noside);
8722 if (noside == EVAL_SKIP)
4c4b4cd2 8723 goto nosideret;
14f9c5c9 8724 if (type != check_typedef (VALUE_TYPE (arg1)))
4c4b4cd2
PH
8725 {
8726 if (ada_is_fixed_point_type (type))
8727 arg1 = cast_to_fixed (type, arg1);
8728 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
8729 arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
8730 else if (VALUE_LVAL (arg1) == lval_memory)
8731 {
8732 /* This is in case of the really obscure (and undocumented,
8733 but apparently expected) case of (Foo) Bar.all, where Bar
8734 is an integer constant and Foo is a dynamic-sized type.
8735 If we don't do this, ARG1 will simply be relabeled with
8736 TYPE. */
8737 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8738 return value_zero (to_static_fixed_type (type), not_lval);
8739 arg1 =
8740 ada_to_fixed_value_create
8741 (type, VALUE_ADDRESS (arg1) + VALUE_OFFSET (arg1), 0);
8742 }
8743 else
8744 arg1 = value_cast (type, arg1);
8745 }
14f9c5c9
AS
8746 return arg1;
8747
4c4b4cd2
PH
8748 case UNOP_QUAL:
8749 (*pos) += 2;
8750 type = exp->elts[pc + 1].type;
8751 return ada_evaluate_subexp (type, exp, pos, noside);
8752
14f9c5c9
AS
8753 case BINOP_ASSIGN:
8754 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8755 arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
8756 if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
8757 return arg1;
8758 if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
76a01679 8759 arg2 = cast_to_fixed (VALUE_TYPE (arg1), arg2);
4c4b4cd2 8760 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
76a01679
JB
8761 error
8762 ("Fixed-point values must be assigned to fixed-point variables");
d2e4a39e 8763 else
76a01679 8764 arg2 = coerce_for_assign (VALUE_TYPE (arg1), arg2);
4c4b4cd2 8765 return ada_value_assign (arg1, arg2);
14f9c5c9
AS
8766
8767 case BINOP_ADD:
8768 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8769 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8770 if (noside == EVAL_SKIP)
4c4b4cd2
PH
8771 goto nosideret;
8772 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
76a01679
JB
8773 || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
8774 && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
8775 error ("Operands of fixed-point addition must have the same type");
4c4b4cd2 8776 return value_cast (VALUE_TYPE (arg1), value_add (arg1, arg2));
14f9c5c9
AS
8777
8778 case BINOP_SUB:
8779 arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
8780 arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
8781 if (noside == EVAL_SKIP)
4c4b4cd2
PH
8782 goto nosideret;
8783 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
76a01679
JB
8784 || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
8785 && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
8786 error ("Operands of fixed-point subtraction must have the same type");
4c4b4cd2 8787 return value_cast (VALUE_TYPE (arg1), value_sub (arg1, arg2));
14f9c5c9
AS
8788
8789 case BINOP_MUL:
8790 case BINOP_DIV:
8791 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8792 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8793 if (noside == EVAL_SKIP)
4c4b4cd2
PH
8794 goto nosideret;
8795 else if (noside == EVAL_AVOID_SIDE_EFFECTS
76a01679 8796 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
4c4b4cd2 8797 return value_zero (VALUE_TYPE (arg1), not_lval);
14f9c5c9 8798 else
4c4b4cd2
PH
8799 {
8800 if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
8801 arg1 = cast_from_fixed_to_double (arg1);
8802 if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
8803 arg2 = cast_from_fixed_to_double (arg2);
8804 return ada_value_binop (arg1, arg2, op);
8805 }
8806
8807 case BINOP_REM:
8808 case BINOP_MOD:
8809 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8810 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8811 if (noside == EVAL_SKIP)
76a01679 8812 goto nosideret;
4c4b4cd2 8813 else if (noside == EVAL_AVOID_SIDE_EFFECTS
76a01679
JB
8814 && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
8815 return value_zero (VALUE_TYPE (arg1), not_lval);
14f9c5c9 8816 else
76a01679 8817 return ada_value_binop (arg1, arg2, op);
14f9c5c9 8818
4c4b4cd2
PH
8819 case BINOP_EQUAL:
8820 case BINOP_NOTEQUAL:
14f9c5c9 8821 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 8822 arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
14f9c5c9 8823 if (noside == EVAL_SKIP)
76a01679 8824 goto nosideret;
4c4b4cd2 8825 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 8826 tem = 0;
4c4b4cd2 8827 else
76a01679 8828 tem = ada_value_equal (arg1, arg2);
4c4b4cd2 8829 if (op == BINOP_NOTEQUAL)
76a01679 8830 tem = !tem;
4c4b4cd2
PH
8831 return value_from_longest (LA_BOOL_TYPE, (LONGEST) tem);
8832
8833 case UNOP_NEG:
8834 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8835 if (noside == EVAL_SKIP)
8836 goto nosideret;
14f9c5c9 8837 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
4c4b4cd2 8838 return value_cast (VALUE_TYPE (arg1), value_neg (arg1));
14f9c5c9 8839 else
4c4b4cd2
PH
8840 return value_neg (arg1);
8841
14f9c5c9
AS
8842 case OP_VAR_VALUE:
8843 *pos -= 1;
8844 if (noside == EVAL_SKIP)
4c4b4cd2
PH
8845 {
8846 *pos += 4;
8847 goto nosideret;
8848 }
8849 else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
76a01679
JB
8850 /* Only encountered when an unresolved symbol occurs in a
8851 context other than a function call, in which case, it is
8852 illegal. */
4c4b4cd2
PH
8853 error ("Unexpected unresolved symbol, %s, during evaluation",
8854 SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
14f9c5c9 8855 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
8856 {
8857 *pos += 4;
8858 return value_zero
8859 (to_static_fixed_type
8860 (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
8861 not_lval);
8862 }
d2e4a39e 8863 else
4c4b4cd2
PH
8864 {
8865 arg1 =
8866 unwrap_value (evaluate_subexp_standard
8867 (expect_type, exp, pos, noside));
8868 return ada_to_fixed_value (arg1);
8869 }
8870
8871 case OP_FUNCALL:
8872 (*pos) += 2;
8873
8874 /* Allocate arg vector, including space for the function to be
8875 called in argvec[0] and a terminating NULL. */
8876 nargs = longest_to_int (exp->elts[pc + 1].longconst);
8877 argvec =
8878 (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
8879
8880 if (exp->elts[*pos].opcode == OP_VAR_VALUE
76a01679 8881 && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
4c4b4cd2
PH
8882 error ("Unexpected unresolved symbol, %s, during evaluation",
8883 SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
8884 else
8885 {
8886 for (tem = 0; tem <= nargs; tem += 1)
8887 argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8888 argvec[tem] = 0;
8889
8890 if (noside == EVAL_SKIP)
8891 goto nosideret;
8892 }
8893
8894 if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec[0]))))
8895 argvec[0] = ada_coerce_to_simple_array (argvec[0]);
8896 else if (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_REF
76a01679
JB
8897 || (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_ARRAY
8898 && VALUE_LVAL (argvec[0]) == lval_memory))
4c4b4cd2
PH
8899 argvec[0] = value_addr (argvec[0]);
8900
8901 type = check_typedef (VALUE_TYPE (argvec[0]));
8902 if (TYPE_CODE (type) == TYPE_CODE_PTR)
8903 {
8904 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type))))
8905 {
8906 case TYPE_CODE_FUNC:
8907 type = check_typedef (TYPE_TARGET_TYPE (type));
8908 break;
8909 case TYPE_CODE_ARRAY:
8910 break;
8911 case TYPE_CODE_STRUCT:
8912 if (noside != EVAL_AVOID_SIDE_EFFECTS)
8913 argvec[0] = ada_value_ind (argvec[0]);
8914 type = check_typedef (TYPE_TARGET_TYPE (type));
8915 break;
8916 default:
8917 error ("cannot subscript or call something of type `%s'",
8918 ada_type_name (VALUE_TYPE (argvec[0])));
8919 break;
8920 }
8921 }
8922
8923 switch (TYPE_CODE (type))
8924 {
8925 case TYPE_CODE_FUNC:
8926 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8927 return allocate_value (TYPE_TARGET_TYPE (type));
8928 return call_function_by_hand (argvec[0], nargs, argvec + 1);
8929 case TYPE_CODE_STRUCT:
8930 {
8931 int arity;
8932
8933 /* Make sure to use the parallel ___XVS type if any.
8934 Otherwise, we won't be able to find the array arity
8935 and element type. */
8936 type = ada_get_base_type (type);
8937
8938 arity = ada_array_arity (type);
8939 type = ada_array_element_type (type, nargs);
8940 if (type == NULL)
8941 error ("cannot subscript or call a record");
8942 if (arity != nargs)
8943 error ("wrong number of subscripts; expecting %d", arity);
8944 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8945 return allocate_value (ada_aligned_type (type));
8946 return
8947 unwrap_value (ada_value_subscript
8948 (argvec[0], nargs, argvec + 1));
8949 }
8950 case TYPE_CODE_ARRAY:
8951 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8952 {
8953 type = ada_array_element_type (type, nargs);
8954 if (type == NULL)
8955 error ("element type of array unknown");
8956 else
8957 return allocate_value (ada_aligned_type (type));
8958 }
8959 return
8960 unwrap_value (ada_value_subscript
8961 (ada_coerce_to_simple_array (argvec[0]),
8962 nargs, argvec + 1));
8963 case TYPE_CODE_PTR: /* Pointer to array */
8964 type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
8965 if (noside == EVAL_AVOID_SIDE_EFFECTS)
8966 {
8967 type = ada_array_element_type (type, nargs);
8968 if (type == NULL)
8969 error ("element type of array unknown");
8970 else
8971 return allocate_value (ada_aligned_type (type));
8972 }
8973 return
8974 unwrap_value (ada_value_ptr_subscript (argvec[0], type,
8975 nargs, argvec + 1));
8976
8977 default:
8978 error ("Internal error in evaluate_subexp");
8979 }
8980
8981 case TERNOP_SLICE:
8982 {
8983 struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
8984 struct value *low_bound_val =
8985 evaluate_subexp (NULL_TYPE, exp, pos, noside);
8986 LONGEST low_bound = pos_atr (low_bound_val);
8987 LONGEST high_bound
8988 = pos_atr (evaluate_subexp (NULL_TYPE, exp, pos, noside));
8989 if (noside == EVAL_SKIP)
8990 goto nosideret;
8991
8992 /* If this is a reference type or a pointer type, and
8993 the target type has an XVS parallel type, then get
8994 the real target type. */
8995 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
8996 || TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR)
8997 TYPE_TARGET_TYPE (VALUE_TYPE (array)) =
8998 ada_get_base_type (TYPE_TARGET_TYPE (VALUE_TYPE (array)));
8999
9000 /* If this is a reference to an aligner type, then remove all
9001 the aligners. */
9002 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
9003 && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array))))
9004 TYPE_TARGET_TYPE (VALUE_TYPE (array)) =
9005 ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array)));
9006
76a01679
JB
9007 if (ada_is_packed_array_type (VALUE_TYPE (array)))
9008 error ("cannot slice a packed array");
4c4b4cd2
PH
9009
9010 /* If this is a reference to an array or an array lvalue,
9011 convert to a pointer. */
9012 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
9013 || (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_ARRAY
9014 && VALUE_LVAL (array) == lval_memory))
9015 array = value_addr (array);
9016
1265e4aa
JB
9017 if (noside == EVAL_AVOID_SIDE_EFFECTS
9018 && ada_is_array_descriptor_type
9019 (check_typedef (VALUE_TYPE (array))))
4c4b4cd2
PH
9020 {
9021 /* Try dereferencing the array, in case it is an access
9022 to array. */
9023 struct type *arrType = ada_type_of_array (array, 0);
9024 if (arrType != NULL)
9025 array = value_at_lazy (arrType, 0, NULL);
9026 }
9027
9028 array = ada_coerce_to_simple_array_ptr (array);
9029
9030 /* When EVAL_AVOID_SIDE_EFFECTS, we may get the bounds wrong,
9031 but only in contexts where the value is not being requested
9032 (FIXME?). */
9033 if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR)
9034 {
9035 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9036 return ada_value_ind (array);
9037 else if (high_bound < low_bound)
9038 return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array)),
9039 low_bound);
9040 else
9041 {
9042 struct type *arr_type0 =
9043 to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array)),
9044 NULL, 1);
9045 struct value *item0 =
9046 ada_value_ptr_subscript (array, arr_type0, 1,
9047 &low_bound_val);
9048 struct value *slice =
9049 value_repeat (item0, high_bound - low_bound + 1);
9050 struct type *arr_type1 = VALUE_TYPE (slice);
9051 TYPE_LOW_BOUND (TYPE_INDEX_TYPE (arr_type1)) = low_bound;
9052 TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (arr_type1)) += low_bound;
9053 return slice;
9054 }
9055 }
9056 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9057 return array;
9058 else if (high_bound < low_bound)
9059 return empty_array (VALUE_TYPE (array), low_bound);
9060 else
9061 return value_slice (array, low_bound, high_bound - low_bound + 1);
9062 }
14f9c5c9 9063
4c4b4cd2
PH
9064 case UNOP_IN_RANGE:
9065 (*pos) += 2;
9066 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9067 type = exp->elts[pc + 1].type;
14f9c5c9 9068
14f9c5c9 9069 if (noside == EVAL_SKIP)
4c4b4cd2 9070 goto nosideret;
14f9c5c9 9071
4c4b4cd2
PH
9072 switch (TYPE_CODE (type))
9073 {
9074 default:
9075 lim_warning ("Membership test incompletely implemented; "
9076 "always returns true", 0);
9077 return value_from_longest (builtin_type_int, (LONGEST) 1);
9078
9079 case TYPE_CODE_RANGE:
76a01679 9080 arg2 = value_from_longest (builtin_type_int, TYPE_LOW_BOUND (type));
4c4b4cd2
PH
9081 arg3 = value_from_longest (builtin_type_int,
9082 TYPE_HIGH_BOUND (type));
9083 return
9084 value_from_longest (builtin_type_int,
9085 (value_less (arg1, arg3)
9086 || value_equal (arg1, arg3))
9087 && (value_less (arg2, arg1)
9088 || value_equal (arg2, arg1)));
9089 }
9090
9091 case BINOP_IN_BOUNDS:
14f9c5c9 9092 (*pos) += 2;
4c4b4cd2
PH
9093 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9094 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
14f9c5c9 9095
4c4b4cd2
PH
9096 if (noside == EVAL_SKIP)
9097 goto nosideret;
14f9c5c9 9098
4c4b4cd2
PH
9099 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9100 return value_zero (builtin_type_int, not_lval);
14f9c5c9 9101
4c4b4cd2 9102 tem = longest_to_int (exp->elts[pc + 1].longconst);
14f9c5c9 9103
4c4b4cd2
PH
9104 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
9105 error ("invalid dimension number to '%s", "range");
14f9c5c9 9106
4c4b4cd2
PH
9107 arg3 = ada_array_bound (arg2, tem, 1);
9108 arg2 = ada_array_bound (arg2, tem, 0);
d2e4a39e 9109
4c4b4cd2
PH
9110 return
9111 value_from_longest (builtin_type_int,
9112 (value_less (arg1, arg3)
9113 || value_equal (arg1, arg3))
9114 && (value_less (arg2, arg1)
9115 || value_equal (arg2, arg1)));
9116
9117 case TERNOP_IN_RANGE:
9118 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9119 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9120 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9121
9122 if (noside == EVAL_SKIP)
9123 goto nosideret;
9124
9125 return
9126 value_from_longest (builtin_type_int,
9127 (value_less (arg1, arg3)
9128 || value_equal (arg1, arg3))
9129 && (value_less (arg2, arg1)
9130 || value_equal (arg2, arg1)));
9131
9132 case OP_ATR_FIRST:
9133 case OP_ATR_LAST:
9134 case OP_ATR_LENGTH:
9135 {
76a01679
JB
9136 struct type *type_arg;
9137 if (exp->elts[*pos].opcode == OP_TYPE)
9138 {
9139 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
9140 arg1 = NULL;
9141 type_arg = exp->elts[pc + 2].type;
9142 }
9143 else
9144 {
9145 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9146 type_arg = NULL;
9147 }
9148
9149 if (exp->elts[*pos].opcode != OP_LONG)
9150 error ("illegal operand to '%s", ada_attribute_name (op));
9151 tem = longest_to_int (exp->elts[*pos + 2].longconst);
9152 *pos += 4;
9153
9154 if (noside == EVAL_SKIP)
9155 goto nosideret;
9156
9157 if (type_arg == NULL)
9158 {
9159 arg1 = ada_coerce_ref (arg1);
9160
9161 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
9162 arg1 = ada_coerce_to_simple_array (arg1);
9163
9164 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
9165 error ("invalid dimension number to '%s",
9166 ada_attribute_name (op));
9167
9168 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9169 {
9170 type = ada_index_type (VALUE_TYPE (arg1), tem);
9171 if (type == NULL)
9172 error
9173 ("attempt to take bound of something that is not an array");
9174 return allocate_value (type);
9175 }
9176
9177 switch (op)
9178 {
9179 default: /* Should never happen. */
9180 error ("unexpected attribute encountered");
9181 case OP_ATR_FIRST:
9182 return ada_array_bound (arg1, tem, 0);
9183 case OP_ATR_LAST:
9184 return ada_array_bound (arg1, tem, 1);
9185 case OP_ATR_LENGTH:
9186 return ada_array_length (arg1, tem);
9187 }
9188 }
9189 else if (discrete_type_p (type_arg))
9190 {
9191 struct type *range_type;
9192 char *name = ada_type_name (type_arg);
9193 range_type = NULL;
9194 if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
9195 range_type =
9196 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
9197 if (range_type == NULL)
9198 range_type = type_arg;
9199 switch (op)
9200 {
9201 default:
9202 error ("unexpected attribute encountered");
9203 case OP_ATR_FIRST:
9204 return discrete_type_low_bound (range_type);
9205 case OP_ATR_LAST:
9206 return discrete_type_high_bound (range_type);
9207 case OP_ATR_LENGTH:
9208 error ("the 'length attribute applies only to array types");
9209 }
9210 }
9211 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
9212 error ("unimplemented type attribute");
9213 else
9214 {
9215 LONGEST low, high;
9216
9217 if (ada_is_packed_array_type (type_arg))
9218 type_arg = decode_packed_array_type (type_arg);
9219
9220 if (tem < 1 || tem > ada_array_arity (type_arg))
9221 error ("invalid dimension number to '%s",
9222 ada_attribute_name (op));
9223
9224 type = ada_index_type (type_arg, tem);
9225 if (type == NULL)
9226 error
9227 ("attempt to take bound of something that is not an array");
9228 if (noside == EVAL_AVOID_SIDE_EFFECTS)
9229 return allocate_value (type);
9230
9231 switch (op)
9232 {
9233 default:
9234 error ("unexpected attribute encountered");
9235 case OP_ATR_FIRST:
9236 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
9237 return value_from_longest (type, low);
9238 case OP_ATR_LAST:
9239 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
9240 return value_from_longest (type, high);
9241 case OP_ATR_LENGTH:
9242 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
9243 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
9244 return value_from_longest (type, high - low + 1);
9245 }
9246 }
14f9c5c9
AS
9247 }
9248
4c4b4cd2
PH
9249 case OP_ATR_TAG:
9250 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9251 if (noside == EVAL_SKIP)
76a01679 9252 goto nosideret;
4c4b4cd2
PH
9253
9254 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9255 return value_zero (ada_tag_type (arg1), not_lval);
4c4b4cd2
PH
9256
9257 return ada_value_tag (arg1);
9258
9259 case OP_ATR_MIN:
9260 case OP_ATR_MAX:
9261 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
9262 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9263 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9264 if (noside == EVAL_SKIP)
76a01679 9265 goto nosideret;
d2e4a39e 9266 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9267 return value_zero (VALUE_TYPE (arg1), not_lval);
14f9c5c9 9268 else
76a01679
JB
9269 return value_binop (arg1, arg2,
9270 op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
14f9c5c9 9271
4c4b4cd2
PH
9272 case OP_ATR_MODULUS:
9273 {
76a01679
JB
9274 struct type *type_arg = exp->elts[pc + 2].type;
9275 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
4c4b4cd2 9276
76a01679
JB
9277 if (noside == EVAL_SKIP)
9278 goto nosideret;
4c4b4cd2 9279
76a01679
JB
9280 if (!ada_is_modular_type (type_arg))
9281 error ("'modulus must be applied to modular type");
4c4b4cd2 9282
76a01679
JB
9283 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
9284 ada_modulus (type_arg));
4c4b4cd2
PH
9285 }
9286
9287
9288 case OP_ATR_POS:
9289 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9
AS
9290 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9291 if (noside == EVAL_SKIP)
76a01679 9292 goto nosideret;
4c4b4cd2 9293 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9294 return value_zero (builtin_type_ada_int, not_lval);
14f9c5c9 9295 else
76a01679 9296 return value_pos_atr (arg1);
14f9c5c9 9297
4c4b4cd2
PH
9298 case OP_ATR_SIZE:
9299 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9300 if (noside == EVAL_SKIP)
76a01679 9301 goto nosideret;
4c4b4cd2 9302 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9303 return value_zero (builtin_type_ada_int, not_lval);
4c4b4cd2 9304 else
76a01679
JB
9305 return value_from_longest (builtin_type_ada_int,
9306 TARGET_CHAR_BIT
9307 * TYPE_LENGTH (VALUE_TYPE (arg1)));
4c4b4cd2
PH
9308
9309 case OP_ATR_VAL:
9310 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
14f9c5c9 9311 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
4c4b4cd2 9312 type = exp->elts[pc + 2].type;
14f9c5c9 9313 if (noside == EVAL_SKIP)
76a01679 9314 goto nosideret;
4c4b4cd2 9315 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679 9316 return value_zero (type, not_lval);
4c4b4cd2 9317 else
76a01679 9318 return value_val_atr (type, arg1);
4c4b4cd2
PH
9319
9320 case BINOP_EXP:
9321 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9322 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9323 if (noside == EVAL_SKIP)
9324 goto nosideret;
9325 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
9326 return value_zero (VALUE_TYPE (arg1), not_lval);
9327 else
9328 return value_binop (arg1, arg2, op);
9329
9330 case UNOP_PLUS:
9331 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9332 if (noside == EVAL_SKIP)
9333 goto nosideret;
9334 else
9335 return arg1;
9336
9337 case UNOP_ABS:
9338 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9339 if (noside == EVAL_SKIP)
9340 goto nosideret;
14f9c5c9 9341 if (value_less (arg1, value_zero (VALUE_TYPE (arg1), not_lval)))
4c4b4cd2 9342 return value_neg (arg1);
14f9c5c9 9343 else
4c4b4cd2 9344 return arg1;
14f9c5c9
AS
9345
9346 case UNOP_IND:
9347 if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
4c4b4cd2 9348 expect_type = TYPE_TARGET_TYPE (check_typedef (expect_type));
14f9c5c9
AS
9349 arg1 = evaluate_subexp (expect_type, exp, pos, noside);
9350 if (noside == EVAL_SKIP)
4c4b4cd2 9351 goto nosideret;
14f9c5c9
AS
9352 type = check_typedef (VALUE_TYPE (arg1));
9353 if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2
PH
9354 {
9355 if (ada_is_array_descriptor_type (type))
9356 /* GDB allows dereferencing GNAT array descriptors. */
9357 {
9358 struct type *arrType = ada_type_of_array (arg1, 0);
9359 if (arrType == NULL)
9360 error ("Attempt to dereference null array pointer.");
9361 return value_at_lazy (arrType, 0, NULL);
9362 }
9363 else if (TYPE_CODE (type) == TYPE_CODE_PTR
9364 || TYPE_CODE (type) == TYPE_CODE_REF
9365 /* In C you can dereference an array to get the 1st elt. */
9366 || TYPE_CODE (type) == TYPE_CODE_ARRAY)
9367 return
9368 value_zero
9369 (to_static_fixed_type
9370 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type)))),
9371 lval_memory);
9372 else if (TYPE_CODE (type) == TYPE_CODE_INT)
9373 /* GDB allows dereferencing an int. */
9374 return value_zero (builtin_type_int, lval_memory);
9375 else
9376 error ("Attempt to take contents of a non-pointer value.");
9377 }
76a01679 9378 arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
14f9c5c9 9379 type = check_typedef (VALUE_TYPE (arg1));
d2e4a39e 9380
4c4b4cd2
PH
9381 if (ada_is_array_descriptor_type (type))
9382 /* GDB allows dereferencing GNAT array descriptors. */
9383 return ada_coerce_to_simple_array (arg1);
14f9c5c9 9384 else
4c4b4cd2 9385 return ada_value_ind (arg1);
14f9c5c9
AS
9386
9387 case STRUCTOP_STRUCT:
9388 tem = longest_to_int (exp->elts[pc + 1].longconst);
9389 (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
9390 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
9391 if (noside == EVAL_SKIP)
4c4b4cd2 9392 goto nosideret;
14f9c5c9 9393 if (noside == EVAL_AVOID_SIDE_EFFECTS)
76a01679
JB
9394 {
9395 struct type *type1 = VALUE_TYPE (arg1);
9396 if (ada_is_tagged_type (type1, 1))
9397 {
9398 type = ada_lookup_struct_elt_type (type1,
9399 &exp->elts[pc + 2].string,
9400 1, 1, NULL);
9401 if (type == NULL)
9402 /* In this case, we assume that the field COULD exist
9403 in some extension of the type. Return an object of
9404 "type" void, which will match any formal
9405 (see ada_type_match). */
9406 return value_zero (builtin_type_void, lval_memory);
9407 }
9408 else
9409 type =
9410 ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string, 1,
9411 0, NULL);
9412
9413 return value_zero (ada_aligned_type (type), lval_memory);
9414 }
14f9c5c9 9415 else
76a01679
JB
9416 return
9417 ada_to_fixed_value (unwrap_value
9418 (ada_value_struct_elt
9419 (arg1, &exp->elts[pc + 2].string, "record")));
14f9c5c9 9420 case OP_TYPE:
4c4b4cd2
PH
9421 /* The value is not supposed to be used. This is here to make it
9422 easier to accommodate expressions that contain types. */
14f9c5c9
AS
9423 (*pos) += 2;
9424 if (noside == EVAL_SKIP)
4c4b4cd2 9425 goto nosideret;
14f9c5c9 9426 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
4c4b4cd2 9427 return allocate_value (builtin_type_void);
14f9c5c9 9428 else
4c4b4cd2 9429 error ("Attempt to use a type name as an expression");
14f9c5c9
AS
9430 }
9431
9432nosideret:
9433 return value_from_longest (builtin_type_long, (LONGEST) 1);
9434}
14f9c5c9 9435\f
d2e4a39e 9436
4c4b4cd2 9437 /* Fixed point */
14f9c5c9
AS
9438
9439/* If TYPE encodes an Ada fixed-point type, return the suffix of the
9440 type name that encodes the 'small and 'delta information.
4c4b4cd2 9441 Otherwise, return NULL. */
14f9c5c9 9442
d2e4a39e 9443static const char *
ebf56fd3 9444fixed_type_info (struct type *type)
14f9c5c9 9445{
d2e4a39e 9446 const char *name = ada_type_name (type);
14f9c5c9
AS
9447 enum type_code code = (type == NULL) ? TYPE_CODE_UNDEF : TYPE_CODE (type);
9448
d2e4a39e
AS
9449 if ((code == TYPE_CODE_INT || code == TYPE_CODE_RANGE) && name != NULL)
9450 {
14f9c5c9
AS
9451 const char *tail = strstr (name, "___XF_");
9452 if (tail == NULL)
4c4b4cd2 9453 return NULL;
d2e4a39e 9454 else
4c4b4cd2 9455 return tail + 5;
14f9c5c9
AS
9456 }
9457 else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
9458 return fixed_type_info (TYPE_TARGET_TYPE (type));
9459 else
9460 return NULL;
9461}
9462
4c4b4cd2 9463/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
14f9c5c9
AS
9464
9465int
ebf56fd3 9466ada_is_fixed_point_type (struct type *type)
14f9c5c9
AS
9467{
9468 return fixed_type_info (type) != NULL;
9469}
9470
4c4b4cd2
PH
9471/* Return non-zero iff TYPE represents a System.Address type. */
9472
9473int
9474ada_is_system_address_type (struct type *type)
9475{
9476 return (TYPE_NAME (type)
9477 && strcmp (TYPE_NAME (type), "system__address") == 0);
9478}
9479
14f9c5c9
AS
9480/* Assuming that TYPE is the representation of an Ada fixed-point
9481 type, return its delta, or -1 if the type is malformed and the
4c4b4cd2 9482 delta cannot be determined. */
14f9c5c9
AS
9483
9484DOUBLEST
ebf56fd3 9485ada_delta (struct type *type)
14f9c5c9
AS
9486{
9487 const char *encoding = fixed_type_info (type);
9488 long num, den;
9489
9490 if (sscanf (encoding, "_%ld_%ld", &num, &den) < 2)
9491 return -1.0;
d2e4a39e 9492 else
14f9c5c9
AS
9493 return (DOUBLEST) num / (DOUBLEST) den;
9494}
9495
9496/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
4c4b4cd2 9497 factor ('SMALL value) associated with the type. */
14f9c5c9
AS
9498
9499static DOUBLEST
ebf56fd3 9500scaling_factor (struct type *type)
14f9c5c9
AS
9501{
9502 const char *encoding = fixed_type_info (type);
9503 unsigned long num0, den0, num1, den1;
9504 int n;
d2e4a39e 9505
14f9c5c9
AS
9506 n = sscanf (encoding, "_%lu_%lu_%lu_%lu", &num0, &den0, &num1, &den1);
9507
9508 if (n < 2)
9509 return 1.0;
9510 else if (n == 4)
9511 return (DOUBLEST) num1 / (DOUBLEST) den1;
d2e4a39e 9512 else
14f9c5c9
AS
9513 return (DOUBLEST) num0 / (DOUBLEST) den0;
9514}
9515
9516
9517/* Assuming that X is the representation of a value of fixed-point
4c4b4cd2 9518 type TYPE, return its floating-point equivalent. */
14f9c5c9
AS
9519
9520DOUBLEST
ebf56fd3 9521ada_fixed_to_float (struct type *type, LONGEST x)
14f9c5c9 9522{
d2e4a39e 9523 return (DOUBLEST) x *scaling_factor (type);
14f9c5c9
AS
9524}
9525
4c4b4cd2
PH
9526/* The representation of a fixed-point value of type TYPE
9527 corresponding to the value X. */
14f9c5c9
AS
9528
9529LONGEST
ebf56fd3 9530ada_float_to_fixed (struct type *type, DOUBLEST x)
14f9c5c9
AS
9531{
9532 return (LONGEST) (x / scaling_factor (type) + 0.5);
9533}
9534
9535
4c4b4cd2 9536 /* VAX floating formats */
14f9c5c9
AS
9537
9538/* Non-zero iff TYPE represents one of the special VAX floating-point
4c4b4cd2
PH
9539 types. */
9540
14f9c5c9 9541int
d2e4a39e 9542ada_is_vax_floating_type (struct type *type)
14f9c5c9 9543{
d2e4a39e 9544 int name_len =
14f9c5c9 9545 (ada_type_name (type) == NULL) ? 0 : strlen (ada_type_name (type));
d2e4a39e 9546 return
14f9c5c9 9547 name_len > 6
d2e4a39e 9548 && (TYPE_CODE (type) == TYPE_CODE_INT
4c4b4cd2
PH
9549 || TYPE_CODE (type) == TYPE_CODE_RANGE)
9550 && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
14f9c5c9
AS
9551}
9552
9553/* The type of special VAX floating-point type this is, assuming
4c4b4cd2
PH
9554 ada_is_vax_floating_point. */
9555
14f9c5c9 9556int
d2e4a39e 9557ada_vax_float_type_suffix (struct type *type)
14f9c5c9 9558{
d2e4a39e 9559 return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
14f9c5c9
AS
9560}
9561
4c4b4cd2 9562/* A value representing the special debugging function that outputs
14f9c5c9 9563 VAX floating-point values of the type represented by TYPE. Assumes
4c4b4cd2
PH
9564 ada_is_vax_floating_type (TYPE). */
9565
d2e4a39e
AS
9566struct value *
9567ada_vax_float_print_function (struct type *type)
9568{
9569 switch (ada_vax_float_type_suffix (type))
9570 {
9571 case 'F':
9572 return get_var_value ("DEBUG_STRING_F", 0);
9573 case 'D':
9574 return get_var_value ("DEBUG_STRING_D", 0);
9575 case 'G':
9576 return get_var_value ("DEBUG_STRING_G", 0);
9577 default:
9578 error ("invalid VAX floating-point type");
9579 }
14f9c5c9 9580}
14f9c5c9 9581\f
d2e4a39e 9582
4c4b4cd2 9583 /* Range types */
14f9c5c9
AS
9584
9585/* Scan STR beginning at position K for a discriminant name, and
9586 return the value of that discriminant field of DVAL in *PX. If
9587 PNEW_K is not null, put the position of the character beyond the
9588 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
4c4b4cd2 9589 not alter *PX and *PNEW_K if unsuccessful. */
14f9c5c9
AS
9590
9591static int
07d8f827 9592scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
76a01679 9593 int *pnew_k)
14f9c5c9
AS
9594{
9595 static char *bound_buffer = NULL;
9596 static size_t bound_buffer_len = 0;
9597 char *bound;
9598 char *pend;
d2e4a39e 9599 struct value *bound_val;
14f9c5c9
AS
9600
9601 if (dval == NULL || str == NULL || str[k] == '\0')
9602 return 0;
9603
d2e4a39e 9604 pend = strstr (str + k, "__");
14f9c5c9
AS
9605 if (pend == NULL)
9606 {
d2e4a39e 9607 bound = str + k;
14f9c5c9
AS
9608 k += strlen (bound);
9609 }
d2e4a39e 9610 else
14f9c5c9 9611 {
d2e4a39e 9612 GROW_VECT (bound_buffer, bound_buffer_len, pend - (str + k) + 1);
14f9c5c9 9613 bound = bound_buffer;
d2e4a39e
AS
9614 strncpy (bound_buffer, str + k, pend - (str + k));
9615 bound[pend - (str + k)] = '\0';
9616 k = pend - str;
14f9c5c9 9617 }
d2e4a39e
AS
9618
9619 bound_val = ada_search_struct_field (bound, dval, 0, VALUE_TYPE (dval));
14f9c5c9
AS
9620 if (bound_val == NULL)
9621 return 0;
9622
9623 *px = value_as_long (bound_val);
9624 if (pnew_k != NULL)
9625 *pnew_k = k;
9626 return 1;
9627}
9628
9629/* Value of variable named NAME in the current environment. If
9630 no such variable found, then if ERR_MSG is null, returns 0, and
4c4b4cd2
PH
9631 otherwise causes an error with message ERR_MSG. */
9632
d2e4a39e
AS
9633static struct value *
9634get_var_value (char *name, char *err_msg)
14f9c5c9 9635{
4c4b4cd2 9636 struct ada_symbol_info *syms;
14f9c5c9
AS
9637 int nsyms;
9638
4c4b4cd2
PH
9639 nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
9640 &syms);
14f9c5c9
AS
9641
9642 if (nsyms != 1)
9643 {
9644 if (err_msg == NULL)
4c4b4cd2 9645 return 0;
14f9c5c9 9646 else
4c4b4cd2 9647 error ("%s", err_msg);
14f9c5c9
AS
9648 }
9649
4c4b4cd2 9650 return value_of_variable (syms[0].sym, syms[0].block);
14f9c5c9 9651}
d2e4a39e 9652
14f9c5c9 9653/* Value of integer variable named NAME in the current environment. If
4c4b4cd2
PH
9654 no such variable found, returns 0, and sets *FLAG to 0. If
9655 successful, sets *FLAG to 1. */
9656
14f9c5c9 9657LONGEST
4c4b4cd2 9658get_int_var_value (char *name, int *flag)
14f9c5c9 9659{
4c4b4cd2 9660 struct value *var_val = get_var_value (name, 0);
d2e4a39e 9661
14f9c5c9
AS
9662 if (var_val == 0)
9663 {
9664 if (flag != NULL)
4c4b4cd2 9665 *flag = 0;
14f9c5c9
AS
9666 return 0;
9667 }
9668 else
9669 {
9670 if (flag != NULL)
4c4b4cd2 9671 *flag = 1;
14f9c5c9
AS
9672 return value_as_long (var_val);
9673 }
9674}
d2e4a39e 9675
14f9c5c9
AS
9676
9677/* Return a range type whose base type is that of the range type named
9678 NAME in the current environment, and whose bounds are calculated
4c4b4cd2 9679 from NAME according to the GNAT range encoding conventions.
14f9c5c9
AS
9680 Extract discriminant values, if needed, from DVAL. If a new type
9681 must be created, allocate in OBJFILE's space. The bounds
9682 information, in general, is encoded in NAME, the base type given in
4c4b4cd2 9683 the named range type. */
14f9c5c9 9684
d2e4a39e 9685static struct type *
ebf56fd3 9686to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
14f9c5c9
AS
9687{
9688 struct type *raw_type = ada_find_any_type (name);
9689 struct type *base_type;
d2e4a39e 9690 char *subtype_info;
14f9c5c9
AS
9691
9692 if (raw_type == NULL)
9693 base_type = builtin_type_int;
9694 else if (TYPE_CODE (raw_type) == TYPE_CODE_RANGE)
9695 base_type = TYPE_TARGET_TYPE (raw_type);
9696 else
9697 base_type = raw_type;
9698
9699 subtype_info = strstr (name, "___XD");
9700 if (subtype_info == NULL)
9701 return raw_type;
9702 else
9703 {
9704 static char *name_buf = NULL;
9705 static size_t name_len = 0;
9706 int prefix_len = subtype_info - name;
9707 LONGEST L, U;
9708 struct type *type;
9709 char *bounds_str;
9710 int n;
9711
9712 GROW_VECT (name_buf, name_len, prefix_len + 5);
9713 strncpy (name_buf, name, prefix_len);
9714 name_buf[prefix_len] = '\0';
9715
9716 subtype_info += 5;
9717 bounds_str = strchr (subtype_info, '_');
9718 n = 1;
9719
d2e4a39e 9720 if (*subtype_info == 'L')
4c4b4cd2
PH
9721 {
9722 if (!ada_scan_number (bounds_str, n, &L, &n)
9723 && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
9724 return raw_type;
9725 if (bounds_str[n] == '_')
9726 n += 2;
9727 else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
9728 n += 1;
9729 subtype_info += 1;
9730 }
d2e4a39e 9731 else
4c4b4cd2
PH
9732 {
9733 int ok;
9734 strcpy (name_buf + prefix_len, "___L");
9735 L = get_int_var_value (name_buf, &ok);
9736 if (!ok)
9737 {
9738 lim_warning ("Unknown lower bound, using 1.", 1);
9739 L = 1;
9740 }
9741 }
14f9c5c9 9742
d2e4a39e 9743 if (*subtype_info == 'U')
4c4b4cd2
PH
9744 {
9745 if (!ada_scan_number (bounds_str, n, &U, &n)
9746 && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
9747 return raw_type;
9748 }
d2e4a39e 9749 else
4c4b4cd2
PH
9750 {
9751 int ok;
9752 strcpy (name_buf + prefix_len, "___U");
9753 U = get_int_var_value (name_buf, &ok);
9754 if (!ok)
9755 {
9756 lim_warning ("Unknown upper bound, using %ld.", (long) L);
9757 U = L;
9758 }
9759 }
14f9c5c9 9760
d2e4a39e 9761 if (objfile == NULL)
4c4b4cd2 9762 objfile = TYPE_OBJFILE (base_type);
14f9c5c9 9763 type = create_range_type (alloc_type (objfile), base_type, L, U);
d2e4a39e 9764 TYPE_NAME (type) = name;
14f9c5c9
AS
9765 return type;
9766 }
9767}
9768
4c4b4cd2
PH
9769/* True iff NAME is the name of a range type. */
9770
14f9c5c9 9771int
d2e4a39e 9772ada_is_range_type_name (const char *name)
14f9c5c9
AS
9773{
9774 return (name != NULL && strstr (name, "___XD"));
d2e4a39e 9775}
14f9c5c9 9776\f
d2e4a39e 9777
4c4b4cd2
PH
9778 /* Modular types */
9779
9780/* True iff TYPE is an Ada modular type. */
14f9c5c9 9781
14f9c5c9 9782int
d2e4a39e 9783ada_is_modular_type (struct type *type)
14f9c5c9 9784{
4c4b4cd2 9785 struct type *subranged_type = base_type (type);
14f9c5c9
AS
9786
9787 return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
4c4b4cd2
PH
9788 && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
9789 && TYPE_UNSIGNED (subranged_type));
14f9c5c9
AS
9790}
9791
4c4b4cd2
PH
9792/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9793
14f9c5c9 9794LONGEST
d2e4a39e 9795ada_modulus (struct type * type)
14f9c5c9 9796{
d2e4a39e 9797 return TYPE_HIGH_BOUND (type) + 1;
14f9c5c9 9798}
d2e4a39e 9799\f
4c4b4cd2
PH
9800 /* Operators */
9801/* Information about operators given special treatment in functions
9802 below. */
9803/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
9804
9805#define ADA_OPERATORS \
9806 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
9807 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
9808 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
9809 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
9810 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
9811 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
9812 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
9813 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
9814 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
9815 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
9816 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
9817 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
9818 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
9819 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
9820 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
9821 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
9822
9823static void
9824ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
9825{
9826 switch (exp->elts[pc - 1].opcode)
9827 {
76a01679 9828 default:
4c4b4cd2
PH
9829 operator_length_standard (exp, pc, oplenp, argsp);
9830 break;
9831
9832#define OP_DEFN(op, len, args, binop) \
9833 case op: *oplenp = len; *argsp = args; break;
9834 ADA_OPERATORS;
9835#undef OP_DEFN
9836 }
9837}
9838
9839static char *
9840ada_op_name (enum exp_opcode opcode)
9841{
9842 switch (opcode)
9843 {
76a01679 9844 default:
4c4b4cd2
PH
9845 return op_name_standard (opcode);
9846#define OP_DEFN(op, len, args, binop) case op: return #op;
9847 ADA_OPERATORS;
9848#undef OP_DEFN
9849 }
9850}
9851
9852/* As for operator_length, but assumes PC is pointing at the first
9853 element of the operator, and gives meaningful results only for the
9854 Ada-specific operators. */
9855
9856static void
76a01679
JB
9857ada_forward_operator_length (struct expression *exp, int pc,
9858 int *oplenp, int *argsp)
4c4b4cd2 9859{
76a01679 9860 switch (exp->elts[pc].opcode)
4c4b4cd2
PH
9861 {
9862 default:
9863 *oplenp = *argsp = 0;
9864 break;
9865#define OP_DEFN(op, len, args, binop) \
9866 case op: *oplenp = len; *argsp = args; break;
9867 ADA_OPERATORS;
9868#undef OP_DEFN
9869 }
9870}
9871
9872static int
9873ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
9874{
9875 enum exp_opcode op = exp->elts[elt].opcode;
9876 int oplen, nargs;
9877 int pc = elt;
9878 int i;
76a01679 9879
4c4b4cd2
PH
9880 ada_forward_operator_length (exp, elt, &oplen, &nargs);
9881
76a01679 9882 switch (op)
4c4b4cd2 9883 {
76a01679 9884 /* Ada attributes ('Foo). */
4c4b4cd2
PH
9885 case OP_ATR_FIRST:
9886 case OP_ATR_LAST:
9887 case OP_ATR_LENGTH:
9888 case OP_ATR_IMAGE:
9889 case OP_ATR_MAX:
9890 case OP_ATR_MIN:
9891 case OP_ATR_MODULUS:
9892 case OP_ATR_POS:
9893 case OP_ATR_SIZE:
9894 case OP_ATR_TAG:
9895 case OP_ATR_VAL:
9896 break;
9897
9898 case UNOP_IN_RANGE:
9899 case UNOP_QUAL:
9900 fprintf_filtered (stream, "Type @");
9901 gdb_print_host_address (exp->elts[pc + 1].type, stream);
9902 fprintf_filtered (stream, " (");
9903 type_print (exp->elts[pc + 1].type, NULL, stream, 0);
9904 fprintf_filtered (stream, ")");
9905 break;
9906 case BINOP_IN_BOUNDS:
9907 fprintf_filtered (stream, " (%d)", (int) exp->elts[pc + 2].longconst);
9908 break;
9909 case TERNOP_IN_RANGE:
9910 break;
9911
9912 default:
9913 return dump_subexp_body_standard (exp, stream, elt);
9914 }
9915
9916 elt += oplen;
9917 for (i = 0; i < nargs; i += 1)
9918 elt = dump_subexp (exp, stream, elt);
9919
9920 return elt;
9921}
9922
9923/* The Ada extension of print_subexp (q.v.). */
9924
76a01679
JB
9925static void
9926ada_print_subexp (struct expression *exp, int *pos,
9927 struct ui_file *stream, enum precedence prec)
4c4b4cd2
PH
9928{
9929 int oplen, nargs;
9930 int pc = *pos;
9931 enum exp_opcode op = exp->elts[pc].opcode;
9932
9933 ada_forward_operator_length (exp, pc, &oplen, &nargs);
9934
9935 switch (op)
9936 {
9937 default:
9938 print_subexp_standard (exp, pos, stream, prec);
9939 return;
9940
9941 case OP_VAR_VALUE:
9942 *pos += oplen;
9943 fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
9944 return;
9945
9946 case BINOP_IN_BOUNDS:
9947 *pos += oplen;
9948 print_subexp (exp, pos, stream, PREC_SUFFIX);
9949 fputs_filtered (" in ", stream);
9950 print_subexp (exp, pos, stream, PREC_SUFFIX);
9951 fputs_filtered ("'range", stream);
9952 if (exp->elts[pc + 1].longconst > 1)
76a01679
JB
9953 fprintf_filtered (stream, "(%ld)",
9954 (long) exp->elts[pc + 1].longconst);
4c4b4cd2
PH
9955 return;
9956
9957 case TERNOP_IN_RANGE:
9958 *pos += oplen;
9959 if (prec >= PREC_EQUAL)
76a01679 9960 fputs_filtered ("(", stream);
4c4b4cd2
PH
9961 print_subexp (exp, pos, stream, PREC_SUFFIX);
9962 fputs_filtered (" in ", stream);
9963 print_subexp (exp, pos, stream, PREC_EQUAL);
9964 fputs_filtered (" .. ", stream);
9965 print_subexp (exp, pos, stream, PREC_EQUAL);
9966 if (prec >= PREC_EQUAL)
76a01679
JB
9967 fputs_filtered (")", stream);
9968 return;
4c4b4cd2
PH
9969
9970 case OP_ATR_FIRST:
9971 case OP_ATR_LAST:
9972 case OP_ATR_LENGTH:
9973 case OP_ATR_IMAGE:
9974 case OP_ATR_MAX:
9975 case OP_ATR_MIN:
9976 case OP_ATR_MODULUS:
9977 case OP_ATR_POS:
9978 case OP_ATR_SIZE:
9979 case OP_ATR_TAG:
9980 case OP_ATR_VAL:
9981 *pos += oplen;
9982 if (exp->elts[*pos].opcode == OP_TYPE)
76a01679
JB
9983 {
9984 if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
9985 LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
9986 *pos += 3;
9987 }
4c4b4cd2 9988 else
76a01679 9989 print_subexp (exp, pos, stream, PREC_SUFFIX);
4c4b4cd2
PH
9990 fprintf_filtered (stream, "'%s", ada_attribute_name (op));
9991 if (nargs > 1)
76a01679
JB
9992 {
9993 int tem;
9994 for (tem = 1; tem < nargs; tem += 1)
9995 {
9996 fputs_filtered ((tem == 1) ? " (" : ", ", stream);
9997 print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
9998 }
9999 fputs_filtered (")", stream);
10000 }
4c4b4cd2 10001 return;
14f9c5c9 10002
4c4b4cd2
PH
10003 case UNOP_QUAL:
10004 *pos += oplen;
10005 type_print (exp->elts[pc + 1].type, "", stream, 0);
10006 fputs_filtered ("'(", stream);
10007 print_subexp (exp, pos, stream, PREC_PREFIX);
10008 fputs_filtered (")", stream);
10009 return;
14f9c5c9 10010
4c4b4cd2
PH
10011 case UNOP_IN_RANGE:
10012 *pos += oplen;
10013 print_subexp (exp, pos, stream, PREC_SUFFIX);
10014 fputs_filtered (" in ", stream);
10015 LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
10016 return;
10017 }
10018}
14f9c5c9
AS
10019
10020/* Table mapping opcodes into strings for printing operators
10021 and precedences of the operators. */
10022
d2e4a39e
AS
10023static const struct op_print ada_op_print_tab[] = {
10024 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
10025 {"or else", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
10026 {"and then", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
10027 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
10028 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
10029 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
10030 {"=", BINOP_EQUAL, PREC_EQUAL, 0},
10031 {"/=", BINOP_NOTEQUAL, PREC_EQUAL, 0},
10032 {"<=", BINOP_LEQ, PREC_ORDER, 0},
10033 {">=", BINOP_GEQ, PREC_ORDER, 0},
10034 {">", BINOP_GTR, PREC_ORDER, 0},
10035 {"<", BINOP_LESS, PREC_ORDER, 0},
10036 {">>", BINOP_RSH, PREC_SHIFT, 0},
10037 {"<<", BINOP_LSH, PREC_SHIFT, 0},
10038 {"+", BINOP_ADD, PREC_ADD, 0},
10039 {"-", BINOP_SUB, PREC_ADD, 0},
10040 {"&", BINOP_CONCAT, PREC_ADD, 0},
10041 {"*", BINOP_MUL, PREC_MUL, 0},
10042 {"/", BINOP_DIV, PREC_MUL, 0},
10043 {"rem", BINOP_REM, PREC_MUL, 0},
10044 {"mod", BINOP_MOD, PREC_MUL, 0},
10045 {"**", BINOP_EXP, PREC_REPEAT, 0},
10046 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
10047 {"-", UNOP_NEG, PREC_PREFIX, 0},
10048 {"+", UNOP_PLUS, PREC_PREFIX, 0},
10049 {"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
10050 {"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
10051 {"abs ", UNOP_ABS, PREC_PREFIX, 0},
4c4b4cd2
PH
10052 {".all", UNOP_IND, PREC_SUFFIX, 1},
10053 {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
10054 {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
d2e4a39e 10055 {NULL, 0, 0, 0}
14f9c5c9
AS
10056};
10057\f
4c4b4cd2 10058 /* Assorted Types and Interfaces */
14f9c5c9 10059
d2e4a39e
AS
10060struct type *builtin_type_ada_int;
10061struct type *builtin_type_ada_short;
10062struct type *builtin_type_ada_long;
10063struct type *builtin_type_ada_long_long;
10064struct type *builtin_type_ada_char;
10065struct type *builtin_type_ada_float;
10066struct type *builtin_type_ada_double;
10067struct type *builtin_type_ada_long_double;
10068struct type *builtin_type_ada_natural;
10069struct type *builtin_type_ada_positive;
10070struct type *builtin_type_ada_system_address;
10071
10072struct type **const (ada_builtin_types[]) =
10073{
14f9c5c9 10074 &builtin_type_ada_int,
76a01679
JB
10075 &builtin_type_ada_long,
10076 &builtin_type_ada_short,
10077 &builtin_type_ada_char,
10078 &builtin_type_ada_float,
10079 &builtin_type_ada_double,
10080 &builtin_type_ada_long_long,
10081 &builtin_type_ada_long_double,
10082 &builtin_type_ada_natural, &builtin_type_ada_positive,
10083 /* The following types are carried over from C for convenience. */
10084&builtin_type_int,
10085 &builtin_type_long,
10086 &builtin_type_short,
10087 &builtin_type_char,
10088 &builtin_type_float,
10089 &builtin_type_double,
10090 &builtin_type_long_long,
10091 &builtin_type_void,
10092 &builtin_type_signed_char,
10093 &builtin_type_unsigned_char,
10094 &builtin_type_unsigned_short,
10095 &builtin_type_unsigned_int,
10096 &builtin_type_unsigned_long,
10097 &builtin_type_unsigned_long_long,
10098 &builtin_type_long_double,
10099 &builtin_type_complex, &builtin_type_double_complex, 0};
4c4b4cd2
PH
10100
10101/* Not really used, but needed in the ada_language_defn. */
10102
d2e4a39e
AS
10103static void
10104emit_char (int c, struct ui_file *stream, int quoter)
14f9c5c9
AS
10105{
10106 ada_emit_char (c, stream, quoter, 1);
10107}
10108
4c4b4cd2
PH
10109static int
10110parse ()
10111{
10112 warnings_issued = 0;
10113 return ada_parse ();
10114}
10115
76a01679 10116static const struct exp_descriptor ada_exp_descriptor = {
4c4b4cd2
PH
10117 ada_print_subexp,
10118 ada_operator_length,
10119 ada_op_name,
10120 ada_dump_subexp_body,
10121 ada_evaluate_subexp
10122};
10123
14f9c5c9 10124const struct language_defn ada_language_defn = {
4c4b4cd2
PH
10125 "ada", /* Language name */
10126 language_ada,
14f9c5c9
AS
10127 ada_builtin_types,
10128 range_check_off,
10129 type_check_off,
4c4b4cd2
PH
10130 case_sensitive_on, /* Yes, Ada is case-insensitive, but
10131 that's not quite what this means. */
10132#ifdef GNAT_GDB
10133 ada_lookup_symbol,
10134 ada_lookup_minimal_symbol,
76a01679 10135#endif /* GNAT_GDB */
4c4b4cd2
PH
10136 &ada_exp_descriptor,
10137 parse,
14f9c5c9 10138 ada_error,
4c4b4cd2 10139 resolve,
76a01679
JB
10140 ada_printchar, /* Print a character constant */
10141 ada_printstr, /* Function to print string constant */
10142 emit_char, /* Function to print single char (not used) */
10143 ada_create_fundamental_type, /* Create fundamental type in this language */
10144 ada_print_type, /* Print a type using appropriate syntax */
10145 ada_val_print, /* Print a value using appropriate syntax */
10146 ada_value_print, /* Print a top-level value */
10147 NULL, /* Language specific skip_trampoline */
10148 NULL, /* value_of_this */
4c4b4cd2 10149 ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
76a01679
JB
10150 basic_lookup_transparent_type, /* lookup_transparent_type */
10151 ada_la_decode, /* Language specific symbol demangler */
10152 {"", "", "", ""}, /* Binary format info */
14f9c5c9 10153#if 0
4c4b4cd2
PH
10154 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
10155 {"%ld", "", "d", ""}, /* Decimal format info */
10156 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
14f9c5c9 10157#else
4c4b4cd2
PH
10158 /* Copied from c-lang.c. */
10159 {"0%lo", "0", "o", ""}, /* Octal format info */
10160 {"%ld", "", "d", ""}, /* Decimal format info */
10161 {"0x%lx", "0x", "x", ""}, /* Hex format info */
14f9c5c9 10162#endif
4c4b4cd2
PH
10163 ada_op_print_tab, /* expression operators for printing */
10164 0, /* c-style arrays */
10165 1, /* String lower bound */
14f9c5c9 10166 &builtin_type_ada_char,
4c4b4cd2
PH
10167 ada_get_gdb_completer_word_break_characters,
10168#ifdef GNAT_GDB
10169 ada_translate_error_message, /* Substitute Ada-specific terminology
76a01679
JB
10170 in errors and warnings. */
10171#endif /* GNAT_GDB */
14f9c5c9
AS
10172 LANG_MAGIC
10173};
10174
4c4b4cd2 10175static void
76a01679
JB
10176build_ada_types (void)
10177{
14f9c5c9
AS
10178 builtin_type_ada_int =
10179 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10180 0, "integer", (struct objfile *) NULL);
14f9c5c9
AS
10181 builtin_type_ada_long =
10182 init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10183 0, "long_integer", (struct objfile *) NULL);
14f9c5c9
AS
10184 builtin_type_ada_short =
10185 init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10186 0, "short_integer", (struct objfile *) NULL);
14f9c5c9
AS
10187 builtin_type_ada_char =
10188 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10189 0, "character", (struct objfile *) NULL);
14f9c5c9
AS
10190 builtin_type_ada_float =
10191 init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10192 0, "float", (struct objfile *) NULL);
14f9c5c9
AS
10193 builtin_type_ada_double =
10194 init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10195 0, "long_float", (struct objfile *) NULL);
14f9c5c9
AS
10196 builtin_type_ada_long_long =
10197 init_type (TYPE_CODE_INT, TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10198 0, "long_long_integer", (struct objfile *) NULL);
14f9c5c9
AS
10199 builtin_type_ada_long_double =
10200 init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10201 0, "long_long_float", (struct objfile *) NULL);
14f9c5c9
AS
10202 builtin_type_ada_natural =
10203 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10204 0, "natural", (struct objfile *) NULL);
14f9c5c9
AS
10205 builtin_type_ada_positive =
10206 init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
4c4b4cd2 10207 0, "positive", (struct objfile *) NULL);
14f9c5c9
AS
10208
10209
d2e4a39e
AS
10210 builtin_type_ada_system_address =
10211 lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
4c4b4cd2 10212 (struct objfile *) NULL));
14f9c5c9 10213 TYPE_NAME (builtin_type_ada_system_address) = "system__address";
4c4b4cd2
PH
10214}
10215
10216void
10217_initialize_ada_language (void)
10218{
14f9c5c9 10219
4c4b4cd2
PH
10220 build_ada_types ();
10221 deprecated_register_gdbarch_swap (NULL, 0, build_ada_types);
14f9c5c9
AS
10222 add_language (&ada_language_defn);
10223
96d887e8 10224 varsize_limit = 65536;
4c4b4cd2 10225#ifdef GNAT_GDB
d2e4a39e 10226 add_show_from_set
14f9c5c9 10227 (add_set_cmd ("varsize-limit", class_support, var_uinteger,
4c4b4cd2
PH
10228 (char *) &varsize_limit,
10229 "Set maximum bytes in dynamic-sized object.",
10230 &setlist), &showlist);
96d887e8 10231 obstack_init (&cache_space);
76a01679 10232#endif /* GNAT_GDB */
14f9c5c9 10233
4c4b4cd2 10234 obstack_init (&symbol_list_obstack);
14f9c5c9 10235
76a01679
JB
10236 decoded_names_store = htab_create_alloc_ex
10237 (256, htab_hash_string, (int (*)(const void *, const void *)) streq,
4c4b4cd2
PH
10238 NULL, NULL, xmcalloc, xmfree);
10239}
14f9c5c9
AS
10240
10241/* Create a fundamental Ada type using default reasonable for the current
10242 target machine.
10243
10244 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
10245 define fundamental types such as "int" or "double". Others (stabs or
10246 DWARF version 2, etc) do define fundamental types. For the formats which
10247 don't provide fundamental types, gdb can create such types using this
10248 function.
10249
10250 FIXME: Some compilers distinguish explicitly signed integral types
10251 (signed short, signed int, signed long) from "regular" integral types
10252 (short, int, long) in the debugging information. There is some dis-
10253 agreement as to how useful this feature is. In particular, gcc does
10254 not support this. Also, only some debugging formats allow the
10255 distinction to be passed on to a debugger. For now, we always just
10256 use "short", "int", or "long" as the type name, for both the implicit
10257 and explicitly signed types. This also makes life easier for the
10258 gdb test suite since we don't have to account for the differences
10259 in output depending upon what the compiler and debugging format
10260 support. We will probably have to re-examine the issue when gdb
10261 starts taking it's fundamental type information directly from the
10262 debugging information supplied by the compiler. fnf@cygnus.com */
10263
10264static struct type *
ebf56fd3 10265ada_create_fundamental_type (struct objfile *objfile, int typeid)
14f9c5c9
AS
10266{
10267 struct type *type = NULL;
10268
10269 switch (typeid)
10270 {
d2e4a39e
AS
10271 default:
10272 /* FIXME: For now, if we are asked to produce a type not in this
10273 language, create the equivalent of a C integer type with the
10274 name "<?type?>". When all the dust settles from the type
4c4b4cd2 10275 reconstruction work, this should probably become an error. */
d2e4a39e 10276 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10277 TARGET_INT_BIT / TARGET_CHAR_BIT,
10278 0, "<?type?>", objfile);
d2e4a39e
AS
10279 warning ("internal error: no Ada fundamental type %d", typeid);
10280 break;
10281 case FT_VOID:
10282 type = init_type (TYPE_CODE_VOID,
4c4b4cd2
PH
10283 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10284 0, "void", objfile);
d2e4a39e
AS
10285 break;
10286 case FT_CHAR:
10287 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10288 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10289 0, "character", objfile);
d2e4a39e
AS
10290 break;
10291 case FT_SIGNED_CHAR:
10292 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10293 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10294 0, "signed char", objfile);
d2e4a39e
AS
10295 break;
10296 case FT_UNSIGNED_CHAR:
10297 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10298 TARGET_CHAR_BIT / TARGET_CHAR_BIT,
10299 TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
d2e4a39e
AS
10300 break;
10301 case FT_SHORT:
10302 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10303 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
10304 0, "short_integer", objfile);
d2e4a39e
AS
10305 break;
10306 case FT_SIGNED_SHORT:
10307 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10308 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
10309 0, "short_integer", objfile);
d2e4a39e
AS
10310 break;
10311 case FT_UNSIGNED_SHORT:
10312 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10313 TARGET_SHORT_BIT / TARGET_CHAR_BIT,
10314 TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
d2e4a39e
AS
10315 break;
10316 case FT_INTEGER:
10317 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10318 TARGET_INT_BIT / TARGET_CHAR_BIT,
10319 0, "integer", objfile);
d2e4a39e
AS
10320 break;
10321 case FT_SIGNED_INTEGER:
4c4b4cd2 10322 type = init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT, 0, "integer", objfile); /* FIXME -fnf */
d2e4a39e
AS
10323 break;
10324 case FT_UNSIGNED_INTEGER:
10325 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10326 TARGET_INT_BIT / TARGET_CHAR_BIT,
10327 TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
d2e4a39e
AS
10328 break;
10329 case FT_LONG:
10330 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10331 TARGET_LONG_BIT / TARGET_CHAR_BIT,
10332 0, "long_integer", objfile);
d2e4a39e
AS
10333 break;
10334 case FT_SIGNED_LONG:
10335 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10336 TARGET_LONG_BIT / TARGET_CHAR_BIT,
10337 0, "long_integer", objfile);
d2e4a39e
AS
10338 break;
10339 case FT_UNSIGNED_LONG:
10340 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10341 TARGET_LONG_BIT / TARGET_CHAR_BIT,
10342 TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
d2e4a39e
AS
10343 break;
10344 case FT_LONG_LONG:
10345 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10346 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
10347 0, "long_long_integer", objfile);
d2e4a39e
AS
10348 break;
10349 case FT_SIGNED_LONG_LONG:
10350 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10351 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
10352 0, "long_long_integer", objfile);
d2e4a39e
AS
10353 break;
10354 case FT_UNSIGNED_LONG_LONG:
10355 type = init_type (TYPE_CODE_INT,
4c4b4cd2
PH
10356 TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
10357 TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
d2e4a39e
AS
10358 break;
10359 case FT_FLOAT:
10360 type = init_type (TYPE_CODE_FLT,
4c4b4cd2
PH
10361 TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
10362 0, "float", objfile);
d2e4a39e
AS
10363 break;
10364 case FT_DBL_PREC_FLOAT:
10365 type = init_type (TYPE_CODE_FLT,
4c4b4cd2
PH
10366 TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
10367 0, "long_float", objfile);
d2e4a39e
AS
10368 break;
10369 case FT_EXT_PREC_FLOAT:
10370 type = init_type (TYPE_CODE_FLT,
4c4b4cd2
PH
10371 TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
10372 0, "long_long_float", objfile);
d2e4a39e
AS
10373 break;
10374 }
14f9c5c9
AS
10375 return (type);
10376}
10377
d2e4a39e
AS
10378void
10379ada_dump_symtab (struct symtab *s)
14f9c5c9
AS
10380{
10381 int i;
10382 fprintf (stderr, "New symtab: [\n");
d2e4a39e 10383 fprintf (stderr, " Name: %s/%s;\n",
4c4b4cd2 10384 s->dirname ? s->dirname : "?", s->filename ? s->filename : "?");
14f9c5c9
AS
10385 fprintf (stderr, " Format: %s;\n", s->debugformat);
10386 if (s->linetable != NULL)
10387 {
10388 fprintf (stderr, " Line table (section %d):\n", s->block_line_section);
10389 for (i = 0; i < s->linetable->nitems; i += 1)
4c4b4cd2
PH
10390 {
10391 struct linetable_entry *e = s->linetable->item + i;
10392 fprintf (stderr, " %4ld: %8lx\n", (long) e->line, (long) e->pc);
10393 }
14f9c5c9
AS
10394 }
10395 fprintf (stderr, "]\n");
10396}