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