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