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.
5 This file is part of GDB.
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.
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.
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. */
22 /* Sections of code marked
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. */
36 #include "gdb_string.h"
40 #include "gdb_regex.h"
45 #include "expression.h"
46 #include "parser-defs.h"
52 #include "breakpoint.h"
55 #include "gdb_obstack.h"
57 #include "completer.h"
64 #include "dictionary.h"
66 #ifndef ADA_RETAIN_DOTS
67 #define ADA_RETAIN_DOTS 0
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. */
74 #ifndef TRUNCATION_TOWARDS_ZERO
75 #define TRUNCATION_TOWARDS_ZERO ((-5 / 2) == -2)
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. */
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. */
91 static struct string_vector
xnew_string_vector (int initial_size
);
92 static void string_vector_append (struct string_vector
*sv
, char *str
);
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
);
100 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
102 static void modify_general_field (char *, LONGEST
, int, int);
104 static struct type
*desc_base_type (struct type
*);
106 static struct type
*desc_bounds_type (struct type
*);
108 static struct value
*desc_bounds (struct value
*);
110 static int fat_pntr_bounds_bitpos (struct type
*);
112 static int fat_pntr_bounds_bitsize (struct type
*);
114 static struct type
*desc_data_type (struct type
*);
116 static struct value
*desc_data (struct value
*);
118 static int fat_pntr_data_bitpos (struct type
*);
120 static int fat_pntr_data_bitsize (struct type
*);
122 static struct value
*desc_one_bound (struct value
*, int, int);
124 static int desc_bound_bitpos (struct type
*, int, int);
126 static int desc_bound_bitsize (struct type
*, int, int);
128 static struct type
*desc_index_type (struct type
*, int);
130 static int desc_arity (struct type
*);
132 static int ada_type_match (struct type
*, struct type
*, int);
134 static int ada_args_match (struct symbol
*, struct value
**, int);
136 static struct value
*ensure_lval (struct value
*, CORE_ADDR
*);
138 static struct value
*convert_actual (struct value
*, struct type
*,
141 static struct value
*make_array_descriptor (struct type
*, struct value
*,
144 static void ada_add_block_symbols (struct obstack
*,
145 struct block
*, const char *,
146 domain_enum
, struct objfile
*,
147 struct symtab
*, int);
149 static int is_nonfunction (struct ada_symbol_info
*, int);
151 static void add_defn_to_vec (struct obstack
*, struct symbol
*,
152 struct block
*, struct symtab
*);
154 static int num_defns_collected (struct obstack
*);
156 static struct ada_symbol_info
*defns_collected (struct obstack
*, int);
158 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
159 *, const char *, int,
162 static struct symtab
*symtab_for_sym (struct symbol
*);
164 static struct value
*resolve_subexp (struct expression
**, int *, int,
167 static void replace_operator_with_call (struct expression
**, int, int, int,
168 struct symbol
*, struct block
*);
170 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
172 static char *ada_op_name (enum exp_opcode
);
174 static const char *ada_decoded_op_name (enum exp_opcode
);
176 static int numeric_type_p (struct type
*);
178 static int integer_type_p (struct type
*);
180 static int scalar_type_p (struct type
*);
182 static int discrete_type_p (struct type
*);
184 static struct type
*ada_lookup_struct_elt_type (struct type
*, char *,
187 static char *extended_canonical_line_spec (struct symtab_and_line
,
190 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
193 static struct value
*evaluate_subexp_type (struct expression
*, int *);
195 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
197 static int is_dynamic_field (struct type
*, int);
199 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
200 CORE_ADDR
, struct value
*);
202 static struct type
*to_fixed_array_type (struct type
*, struct value
*, int);
204 static struct type
*to_fixed_range_type (char *, struct value
*,
207 static struct type
*to_static_fixed_type (struct type
*);
209 static struct value
*unwrap_value (struct value
*);
211 static struct type
*packed_array_type (struct type
*, long *);
213 static struct type
*decode_packed_array_type (struct type
*);
215 static struct value
*decode_packed_array (struct value
*);
217 static struct value
*value_subscript_packed (struct value
*, int,
220 static struct value
*coerce_unspec_val_to_type (struct value
*,
223 static struct value
*get_var_value (char *, char *);
225 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
227 static int equiv_types (struct type
*, struct type
*);
229 static int is_name_suffix (const char *);
231 static int wild_match (const char *, int, const char *);
233 static struct symtabs_and_lines
234 find_sal_from_funcs_and_line (const char *, int,
235 struct ada_symbol_info
*, int);
237 static int find_line_in_linetable (struct linetable
*, int,
238 struct ada_symbol_info
*, int, int *);
240 static int find_next_line_in_linetable (struct linetable
*, int, int, int);
242 static void read_all_symtabs (const char *);
244 static int is_plausible_func_for_line (struct symbol
*, int);
246 static struct value
*ada_coerce_ref (struct value
*);
248 static LONGEST
pos_atr (struct value
*);
250 static struct value
*value_pos_atr (struct value
*);
252 static struct value
*value_val_atr (struct type
*, struct value
*);
254 static struct symbol
*standard_lookup (const char *, const struct block
*,
257 static struct value
*ada_search_struct_field (char *, struct value
*, int,
260 static struct value
*ada_value_primitive_field (struct value
*, int, int,
263 static int find_struct_field (char *, struct type
*, int,
264 struct type
**, int *, int *, int *);
266 static struct value
*ada_to_fixed_value_create (struct type
*, CORE_ADDR
,
269 static struct value
*ada_to_fixed_value (struct value
*);
271 static void adjust_pc_past_prologue (CORE_ADDR
*);
273 static int ada_resolve_function (struct ada_symbol_info
*, int,
274 struct value
**, int, const char *,
277 static struct value
*ada_coerce_to_simple_array (struct value
*);
279 static int ada_is_direct_array_type (struct type
*);
281 static void error_breakpoint_runtime_sym_not_found (const char *err_desc
);
283 static int is_runtime_sym_defined (const char *name
, int allow_tramp
);
287 /* Maximum-sized dynamic type. */
288 static unsigned int varsize_limit
;
290 /* FIXME: brobecker/2003-09-17: No longer a const because it is
291 returned by a function that does not return a const char *. */
292 static char *ada_completer_word_break_characters
=
294 " \t\n!@#%^&*()+=|~`}{[]\";:?/,-";
296 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
299 /* The name of the symbol to use to get the name of the main subprogram. */
300 static const char ADA_MAIN_PROGRAM_SYMBOL_NAME
[]
301 = "__gnat_ada_main_program_name";
303 /* The name of the runtime function called when an exception is raised. */
304 static const char raise_sym_name
[] = "__gnat_raise_nodefer_with_msg";
306 /* The name of the runtime function called when an unhandled exception
308 static const char raise_unhandled_sym_name
[] = "__gnat_unhandled_exception";
310 /* The name of the runtime function called when an assert failure is
312 static const char raise_assert_sym_name
[] =
313 "system__assertions__raise_assert_failure";
315 /* When GDB stops on an unhandled exception, GDB will go up the stack until
316 if finds a frame corresponding to this function, in order to extract the
317 name of the exception that has been raised from one of the parameters. */
318 static const char process_raise_exception_name
[] =
319 "ada__exceptions__process_raise_exception";
321 /* A string that reflects the longest exception expression rewrite,
322 aside from the exception name. */
323 static const char longest_exception_template
[] =
324 "'__gnat_raise_nodefer_with_msg' if long_integer(e) = long_integer(&)";
326 /* Limit on the number of warnings to raise per expression evaluation. */
327 static int warning_limit
= 2;
329 /* Number of warning messages issued; reset to 0 by cleanups after
330 expression evaluation. */
331 static int warnings_issued
= 0;
333 static const char *known_runtime_file_name_patterns
[] = {
334 ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS NULL
337 static const char *known_auxiliary_function_name_patterns
[] = {
338 ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS NULL
341 /* Space for allocating results of ada_lookup_symbol_list. */
342 static struct obstack symbol_list_obstack
;
348 /* Create a new empty string_vector struct with an initial size of
351 static struct string_vector
352 xnew_string_vector (int initial_size
)
354 struct string_vector result
;
356 result
.array
= (char **) xmalloc ((initial_size
+ 1) * sizeof (char *));
358 result
.size
= initial_size
;
363 /* Add STR at the end of the given string vector SV. If SV is already
364 full, its size is automatically increased (doubled). */
367 string_vector_append (struct string_vector
*sv
, char *str
)
369 if (sv
->index
>= sv
->size
)
370 GROW_VECT (sv
->array
, sv
->size
, sv
->size
* 2);
372 sv
->array
[sv
->index
] = str
;
376 /* Given DECODED_NAME a string holding a symbol name in its
377 decoded form (ie using the Ada dotted notation), returns
378 its unqualified name. */
381 ada_unqualified_name (const char *decoded_name
)
383 const char *result
= strrchr (decoded_name
, '.');
386 result
++; /* Skip the dot... */
388 result
= decoded_name
;
393 /* Return a string starting with '<', followed by STR, and '>'.
394 The result is good until the next call. */
397 add_angle_brackets (const char *str
)
399 static char *result
= NULL
;
402 result
= (char *) xmalloc ((strlen (str
) + 3) * sizeof (char));
404 sprintf (result
, "<%s>", str
);
408 #endif /* GNAT_GDB */
411 ada_get_gdb_completer_word_break_characters (void)
413 return ada_completer_word_break_characters
;
416 /* Read the string located at ADDR from the inferior and store the
420 extract_string (CORE_ADDR addr
, char *buf
)
424 /* Loop, reading one byte at a time, until we reach the '\000'
425 end-of-string marker. */
428 target_read_memory (addr
+ char_index
* sizeof (char),
429 buf
+ char_index
* sizeof (char), sizeof (char));
432 while (buf
[char_index
- 1] != '\000');
435 /* Return the name of the function owning the instruction located at PC.
436 Return NULL if no such function could be found. */
439 function_name_from_pc (CORE_ADDR pc
)
443 if (!find_pc_partial_function (pc
, &func_name
, NULL
, NULL
))
449 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
450 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
451 updating *OLD_VECT and *SIZE as necessary. */
454 grow_vect (void **old_vect
, size_t * size
, size_t min_size
, int element_size
)
456 if (*size
< min_size
)
459 if (*size
< min_size
)
461 *old_vect
= xrealloc (*old_vect
, *size
* element_size
);
465 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
466 suffix of FIELD_NAME beginning "___". */
469 field_name_match (const char *field_name
, const char *target
)
471 int len
= strlen (target
);
473 (strncmp (field_name
, target
, len
) == 0
474 && (field_name
[len
] == '\0'
475 || (strncmp (field_name
+ len
, "___", 3) == 0
476 && strcmp (field_name
+ strlen (field_name
) - 6,
481 /* Assuming TYPE is a TYPE_CODE_STRUCT, find the field whose name matches
482 FIELD_NAME, and return its index. This function also handles fields
483 whose name have ___ suffixes because the compiler sometimes alters
484 their name by adding such a suffix to represent fields with certain
485 constraints. If the field could not be found, return a negative
486 number if MAYBE_MISSING is set. Otherwise raise an error. */
489 ada_get_field_index (const struct type
*type
, const char *field_name
,
493 for (fieldno
= 0; fieldno
< TYPE_NFIELDS (type
); fieldno
++)
494 if (field_name_match (TYPE_FIELD_NAME (type
, fieldno
), field_name
))
498 error ("Unable to find field %s in struct %s. Aborting",
499 field_name
, TYPE_NAME (type
));
504 /* The length of the prefix of NAME prior to any "___" suffix. */
507 ada_name_prefix_len (const char *name
)
513 const char *p
= strstr (name
, "___");
515 return strlen (name
);
521 /* Return non-zero if SUFFIX is a suffix of STR.
522 Return zero if STR is null. */
525 is_suffix (const char *str
, const char *suffix
)
531 len2
= strlen (suffix
);
532 return (len1
>= len2
&& strcmp (str
+ len1
- len2
, suffix
) == 0);
535 /* Create a value of type TYPE whose contents come from VALADDR, if it
536 is non-null, and whose memory address (in the inferior) is
540 value_from_contents_and_address (struct type
*type
, char *valaddr
,
543 struct value
*v
= allocate_value (type
);
547 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
548 VALUE_ADDRESS (v
) = address
;
550 VALUE_LVAL (v
) = lval_memory
;
554 /* The contents of value VAL, treated as a value of type TYPE. The
555 result is an lval in memory if VAL is. */
557 static struct value
*
558 coerce_unspec_val_to_type (struct value
*val
, struct type
*type
)
560 CHECK_TYPEDEF (type
);
561 if (VALUE_TYPE (val
) == type
)
565 struct value
*result
;
567 /* Make sure that the object size is not unreasonable before
568 trying to allocate some memory for it. */
569 if (TYPE_LENGTH (type
) > varsize_limit
)
570 error ("object size is larger than varsize-limit");
572 result
= allocate_value (type
);
573 VALUE_LVAL (result
) = VALUE_LVAL (val
);
574 VALUE_BITSIZE (result
) = VALUE_BITSIZE (val
);
575 VALUE_BITPOS (result
) = VALUE_BITPOS (val
);
576 VALUE_ADDRESS (result
) = VALUE_ADDRESS (val
) + VALUE_OFFSET (val
);
578 || TYPE_LENGTH (type
) > TYPE_LENGTH (VALUE_TYPE (val
)))
579 VALUE_LAZY (result
) = 1;
581 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
),
588 cond_offset_host (char *valaddr
, long offset
)
593 return valaddr
+ offset
;
597 cond_offset_target (CORE_ADDR address
, long offset
)
602 return address
+ offset
;
605 /* Issue a warning (as for the definition of warning in utils.c, but
606 with exactly one argument rather than ...), unless the limit on the
607 number of warnings has passed during the evaluation of the current
610 lim_warning (const char *format
, long arg
)
612 warnings_issued
+= 1;
613 if (warnings_issued
<= warning_limit
)
614 warning (format
, arg
);
618 ada_translate_error_message (const char *string
)
620 if (strcmp (string
, "Invalid cast.") == 0)
621 return "Invalid type conversion.";
627 MAX_OF_SIZE (int size
)
629 LONGEST top_bit
= (LONGEST
) 1 << (size
* 8 - 2);
630 return top_bit
| (top_bit
- 1);
634 MIN_OF_SIZE (int size
)
636 return -MAX_OF_SIZE (size
) - 1;
640 UMAX_OF_SIZE (int size
)
642 ULONGEST top_bit
= (ULONGEST
) 1 << (size
* 8 - 1);
643 return top_bit
| (top_bit
- 1);
647 UMIN_OF_SIZE (int size
)
652 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
653 static struct value
*
654 discrete_type_high_bound (struct type
*type
)
656 switch (TYPE_CODE (type
))
658 case TYPE_CODE_RANGE
:
659 return value_from_longest (TYPE_TARGET_TYPE (type
),
660 TYPE_HIGH_BOUND (type
));
663 value_from_longest (type
,
664 TYPE_FIELD_BITPOS (type
,
665 TYPE_NFIELDS (type
) - 1));
667 return value_from_longest (type
, MAX_OF_TYPE (type
));
669 error ("Unexpected type in discrete_type_high_bound.");
673 /* The largest value in the domain of TYPE, a discrete type, as an integer. */
674 static struct value
*
675 discrete_type_low_bound (struct type
*type
)
677 switch (TYPE_CODE (type
))
679 case TYPE_CODE_RANGE
:
680 return value_from_longest (TYPE_TARGET_TYPE (type
),
681 TYPE_LOW_BOUND (type
));
683 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, 0));
685 return value_from_longest (type
, MIN_OF_TYPE (type
));
687 error ("Unexpected type in discrete_type_low_bound.");
691 /* The identity on non-range types. For range types, the underlying
692 non-range scalar type. */
695 base_type (struct type
*type
)
697 while (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
)
699 if (type
== TYPE_TARGET_TYPE (type
) || TYPE_TARGET_TYPE (type
) == NULL
)
701 type
= TYPE_TARGET_TYPE (type
);
707 /* Language Selection */
709 /* If the main program is in Ada, return language_ada, otherwise return LANG
710 (the main program is in Ada iif the adainit symbol is found).
712 MAIN_PST is not used. */
715 ada_update_initial_language (enum language lang
,
716 struct partial_symtab
*main_pst
)
718 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
719 (struct objfile
*) NULL
) != NULL
)
725 /* If the main procedure is written in Ada, then return its name.
726 The result is good until the next call. Return NULL if the main
727 procedure doesn't appear to be in Ada. */
732 struct minimal_symbol
*msym
;
733 CORE_ADDR main_program_name_addr
;
734 static char main_program_name
[1024];
735 /* For Ada, the name of the main procedure is stored in a specific
736 string constant, generated by the binder. Look for that symbol,
737 extract its address, and then read that string. If we didn't find
738 that string, then most probably the main procedure is not written
740 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
744 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
745 if (main_program_name_addr
== 0)
746 error ("Invalid address for Ada main program name.");
748 extract_string (main_program_name_addr
, main_program_name
);
749 return main_program_name
;
752 /* The main procedure doesn't seem to be in Ada. */
758 /* Table of Ada operators and their GNAT-encoded names. Last entry is pair
761 const struct ada_opname_map ada_opname_table
[] = {
762 {"Oadd", "\"+\"", BINOP_ADD
},
763 {"Osubtract", "\"-\"", BINOP_SUB
},
764 {"Omultiply", "\"*\"", BINOP_MUL
},
765 {"Odivide", "\"/\"", BINOP_DIV
},
766 {"Omod", "\"mod\"", BINOP_MOD
},
767 {"Orem", "\"rem\"", BINOP_REM
},
768 {"Oexpon", "\"**\"", BINOP_EXP
},
769 {"Olt", "\"<\"", BINOP_LESS
},
770 {"Ole", "\"<=\"", BINOP_LEQ
},
771 {"Ogt", "\">\"", BINOP_GTR
},
772 {"Oge", "\">=\"", BINOP_GEQ
},
773 {"Oeq", "\"=\"", BINOP_EQUAL
},
774 {"One", "\"/=\"", BINOP_NOTEQUAL
},
775 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
776 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
777 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
778 {"Oconcat", "\"&\"", BINOP_CONCAT
},
779 {"Oabs", "\"abs\"", UNOP_ABS
},
780 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
781 {"Oadd", "\"+\"", UNOP_PLUS
},
782 {"Osubtract", "\"-\"", UNOP_NEG
},
786 /* Return non-zero if STR should be suppressed in info listings. */
789 is_suppressed_name (const char *str
)
791 if (strncmp (str
, "_ada_", 5) == 0)
793 if (str
[0] == '_' || str
[0] == '\000')
798 const char *suffix
= strstr (str
, "___");
799 if (suffix
!= NULL
&& suffix
[3] != 'X')
802 suffix
= str
+ strlen (str
);
803 for (p
= suffix
- 1; p
!= str
; p
-= 1)
807 if (p
[0] == 'X' && p
[-1] != '_')
811 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
812 if (strncmp (ada_opname_table
[i
].encoded
, p
,
813 strlen (ada_opname_table
[i
].encoded
)) == 0)
822 /* The "encoded" form of DECODED, according to GNAT conventions.
823 The result is valid until the next call to ada_encode. */
826 ada_encode (const char *decoded
)
828 static char *encoding_buffer
= NULL
;
829 static size_t encoding_buffer_size
= 0;
836 GROW_VECT (encoding_buffer
, encoding_buffer_size
,
837 2 * strlen (decoded
) + 10);
840 for (p
= decoded
; *p
!= '\0'; p
+= 1)
842 if (!ADA_RETAIN_DOTS
&& *p
== '.')
844 encoding_buffer
[k
] = encoding_buffer
[k
+ 1] = '_';
849 const struct ada_opname_map
*mapping
;
851 for (mapping
= ada_opname_table
;
852 mapping
->encoded
!= NULL
853 && strncmp (mapping
->decoded
, p
,
854 strlen (mapping
->decoded
)) != 0; mapping
+= 1)
856 if (mapping
->encoded
== NULL
)
857 error ("invalid Ada operator name: %s", p
);
858 strcpy (encoding_buffer
+ k
, mapping
->encoded
);
859 k
+= strlen (mapping
->encoded
);
864 encoding_buffer
[k
] = *p
;
869 encoding_buffer
[k
] = '\0';
870 return encoding_buffer
;
873 /* Return NAME folded to lower case, or, if surrounded by single
874 quotes, unfolded, but with the quotes stripped away. Result good
878 ada_fold_name (const char *name
)
880 static char *fold_buffer
= NULL
;
881 static size_t fold_buffer_size
= 0;
883 int len
= strlen (name
);
884 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
888 strncpy (fold_buffer
, name
+ 1, len
- 2);
889 fold_buffer
[len
- 2] = '\000';
894 for (i
= 0; i
<= len
; i
+= 1)
895 fold_buffer
[i
] = tolower (name
[i
]);
902 0. Discard trailing .{DIGIT}+ or trailing ___{DIGIT}+
903 These are suffixes introduced by GNAT5 to nested subprogram
904 names, and do not serve any purpose for the debugger.
905 1. Discard final __{DIGIT}+ or $({DIGIT}+(__{DIGIT}+)*)
906 2. Convert other instances of embedded "__" to `.'.
907 3. Discard leading _ada_.
908 4. Convert operator names to the appropriate quoted symbols.
909 5. Remove everything after first ___ if it is followed by
911 6. Replace TK__ with __, and a trailing B or TKB with nothing.
912 7. Put symbols that should be suppressed in <...> brackets.
913 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
915 The resulting string is valid until the next call of ada_decode.
916 If the string is unchanged by demangling, the original string pointer
920 ada_decode (const char *encoded
)
927 static char *decoding_buffer
= NULL
;
928 static size_t decoding_buffer_size
= 0;
930 if (strncmp (encoded
, "_ada_", 5) == 0)
933 if (encoded
[0] == '_' || encoded
[0] == '<')
936 /* Remove trailing .{DIGIT}+ or ___{DIGIT}+. */
937 len0
= strlen (encoded
);
938 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
941 while (i
> 0 && isdigit (encoded
[i
]))
943 if (i
>= 0 && encoded
[i
] == '.')
945 else if (i
>= 2 && strncmp (encoded
+ i
- 2, "___", 3) == 0)
949 /* Remove the ___X.* suffix if present. Do not forget to verify that
950 the suffix is located before the current "end" of ENCODED. We want
951 to avoid re-matching parts of ENCODED that have previously been
952 marked as discarded (by decrementing LEN0). */
953 p
= strstr (encoded
, "___");
954 if (p
!= NULL
&& p
- encoded
< len0
- 3)
962 if (len0
> 3 && strncmp (encoded
+ len0
- 3, "TKB", 3) == 0)
965 if (len0
> 1 && strncmp (encoded
+ len0
- 1, "B", 1) == 0)
968 /* Make decoded big enough for possible expansion by operator name. */
969 GROW_VECT (decoding_buffer
, decoding_buffer_size
, 2 * len0
+ 1);
970 decoded
= decoding_buffer
;
972 if (len0
> 1 && isdigit (encoded
[len0
- 1]))
975 while ((i
>= 0 && isdigit (encoded
[i
]))
976 || (i
>= 1 && encoded
[i
] == '_' && isdigit (encoded
[i
- 1])))
978 if (i
> 1 && encoded
[i
] == '_' && encoded
[i
- 1] == '_')
980 else if (encoded
[i
] == '$')
984 for (i
= 0, j
= 0; i
< len0
&& !isalpha (encoded
[i
]); i
+= 1, j
+= 1)
985 decoded
[j
] = encoded
[i
];
990 if (at_start_name
&& encoded
[i
] == 'O')
993 for (k
= 0; ada_opname_table
[k
].encoded
!= NULL
; k
+= 1)
995 int op_len
= strlen (ada_opname_table
[k
].encoded
);
996 if ((strncmp (ada_opname_table
[k
].encoded
+ 1, encoded
+ i
+ 1,
998 && !isalnum (encoded
[i
+ op_len
]))
1000 strcpy (decoded
+ j
, ada_opname_table
[k
].decoded
);
1003 j
+= strlen (ada_opname_table
[k
].decoded
);
1007 if (ada_opname_table
[k
].encoded
!= NULL
)
1012 if (i
< len0
- 4 && strncmp (encoded
+ i
, "TK__", 4) == 0)
1014 if (encoded
[i
] == 'X' && i
!= 0 && isalnum (encoded
[i
- 1]))
1018 while (i
< len0
&& (encoded
[i
] == 'b' || encoded
[i
] == 'n'));
1022 else if (!ADA_RETAIN_DOTS
1023 && i
< len0
- 2 && encoded
[i
] == '_' && encoded
[i
+ 1] == '_')
1032 decoded
[j
] = encoded
[i
];
1037 decoded
[j
] = '\000';
1039 for (i
= 0; decoded
[i
] != '\0'; i
+= 1)
1040 if (isupper (decoded
[i
]) || decoded
[i
] == ' ')
1043 if (strcmp (decoded
, encoded
) == 0)
1049 GROW_VECT (decoding_buffer
, decoding_buffer_size
, strlen (encoded
) + 3);
1050 decoded
= decoding_buffer
;
1051 if (encoded
[0] == '<')
1052 strcpy (decoded
, encoded
);
1054 sprintf (decoded
, "<%s>", encoded
);
1059 /* Table for keeping permanent unique copies of decoded names. Once
1060 allocated, names in this table are never released. While this is a
1061 storage leak, it should not be significant unless there are massive
1062 changes in the set of decoded names in successive versions of a
1063 symbol table loaded during a single session. */
1064 static struct htab
*decoded_names_store
;
1066 /* Returns the decoded name of GSYMBOL, as for ada_decode, caching it
1067 in the language-specific part of GSYMBOL, if it has not been
1068 previously computed. Tries to save the decoded name in the same
1069 obstack as GSYMBOL, if possible, and otherwise on the heap (so that,
1070 in any case, the decoded symbol has a lifetime at least that of
1072 The GSYMBOL parameter is "mutable" in the C++ sense: logically
1073 const, but nevertheless modified to a semantically equivalent form
1074 when a decoded name is cached in it.
1078 ada_decode_symbol (const struct general_symbol_info
*gsymbol
)
1081 (char **) &gsymbol
->language_specific
.cplus_specific
.demangled_name
;
1082 if (*resultp
== NULL
)
1084 const char *decoded
= ada_decode (gsymbol
->name
);
1085 if (gsymbol
->bfd_section
!= NULL
)
1087 bfd
*obfd
= gsymbol
->bfd_section
->owner
;
1090 struct objfile
*objf
;
1093 if (obfd
== objf
->obfd
)
1095 *resultp
= obsavestring (decoded
, strlen (decoded
),
1096 &objf
->objfile_obstack
);
1102 /* Sometimes, we can't find a corresponding objfile, in which
1103 case, we put the result on the heap. Since we only decode
1104 when needed, we hope this usually does not cause a
1105 significant memory leak (FIXME). */
1106 if (*resultp
== NULL
)
1108 char **slot
= (char **) htab_find_slot (decoded_names_store
,
1111 *slot
= xstrdup (decoded
);
1120 ada_la_decode (const char *encoded
, int options
)
1122 return xstrdup (ada_decode (encoded
));
1125 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
1126 suffixes that encode debugging information or leading _ada_ on
1127 SYM_NAME (see is_name_suffix commentary for the debugging
1128 information that is ignored). If WILD, then NAME need only match a
1129 suffix of SYM_NAME minus the same suffixes. Also returns 0 if
1130 either argument is NULL. */
1133 ada_match_name (const char *sym_name
, const char *name
, int wild
)
1135 if (sym_name
== NULL
|| name
== NULL
)
1138 return wild_match (name
, strlen (name
), sym_name
);
1141 int len_name
= strlen (name
);
1142 return (strncmp (sym_name
, name
, len_name
) == 0
1143 && is_name_suffix (sym_name
+ len_name
))
1144 || (strncmp (sym_name
, "_ada_", 5) == 0
1145 && strncmp (sym_name
+ 5, name
, len_name
) == 0
1146 && is_name_suffix (sym_name
+ len_name
+ 5));
1150 /* True (non-zero) iff, in Ada mode, the symbol SYM should be
1151 suppressed in info listings. */
1154 ada_suppress_symbol_printing (struct symbol
*sym
)
1156 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
1159 return is_suppressed_name (SYMBOL_LINKAGE_NAME (sym
));
1165 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of array descriptors. */
1167 static char *bound_name
[] = {
1168 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
1169 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
1172 /* Maximum number of array dimensions we are prepared to handle. */
1174 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char *)))
1176 /* Like modify_field, but allows bitpos > wordlength. */
1179 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
1181 modify_field (addr
+ bitpos
/ 8, fieldval
, bitpos
% 8, bitsize
);
1185 /* The desc_* routines return primitive portions of array descriptors
1188 /* The descriptor or array type, if any, indicated by TYPE; removes
1189 level of indirection, if needed. */
1191 static struct type
*
1192 desc_base_type (struct type
*type
)
1196 CHECK_TYPEDEF (type
);
1198 && (TYPE_CODE (type
) == TYPE_CODE_PTR
1199 || TYPE_CODE (type
) == TYPE_CODE_REF
))
1200 return check_typedef (TYPE_TARGET_TYPE (type
));
1205 /* True iff TYPE indicates a "thin" array pointer type. */
1208 is_thin_pntr (struct type
*type
)
1211 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
1212 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
1215 /* The descriptor type for thin pointer type TYPE. */
1217 static struct type
*
1218 thin_descriptor_type (struct type
*type
)
1220 struct type
*base_type
= desc_base_type (type
);
1221 if (base_type
== NULL
)
1223 if (is_suffix (ada_type_name (base_type
), "___XVE"))
1227 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
1228 if (alt_type
== NULL
)
1235 /* A pointer to the array data for thin-pointer value VAL. */
1237 static struct value
*
1238 thin_data_pntr (struct value
*val
)
1240 struct type
*type
= VALUE_TYPE (val
);
1241 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1242 return value_cast (desc_data_type (thin_descriptor_type (type
)),
1245 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
1246 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
1249 /* True iff TYPE indicates a "thick" array pointer type. */
1252 is_thick_pntr (struct type
*type
)
1254 type
= desc_base_type (type
);
1255 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
1256 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
1259 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1260 pointer to one, the type of its bounds data; otherwise, NULL. */
1262 static struct type
*
1263 desc_bounds_type (struct type
*type
)
1267 type
= desc_base_type (type
);
1271 else if (is_thin_pntr (type
))
1273 type
= thin_descriptor_type (type
);
1276 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
1278 return check_typedef (r
);
1280 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1282 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
1284 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r
)));
1289 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
1290 one, a pointer to its bounds data. Otherwise NULL. */
1292 static struct value
*
1293 desc_bounds (struct value
*arr
)
1295 struct type
*type
= check_typedef (VALUE_TYPE (arr
));
1296 if (is_thin_pntr (type
))
1298 struct type
*bounds_type
=
1299 desc_bounds_type (thin_descriptor_type (type
));
1302 if (desc_bounds_type
== NULL
)
1303 error ("Bad GNAT array descriptor");
1305 /* NOTE: The following calculation is not really kosher, but
1306 since desc_type is an XVE-encoded type (and shouldn't be),
1307 the correct calculation is a real pain. FIXME (and fix GCC). */
1308 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
1309 addr
= value_as_long (arr
);
1311 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
1314 value_from_longest (lookup_pointer_type (bounds_type
),
1315 addr
- TYPE_LENGTH (bounds_type
));
1318 else if (is_thick_pntr (type
))
1319 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
1320 "Bad GNAT array descriptor");
1325 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1326 position of the field containing the address of the bounds data. */
1329 fat_pntr_bounds_bitpos (struct type
*type
)
1331 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
1334 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1335 size of the field containing the address of the bounds data. */
1338 fat_pntr_bounds_bitsize (struct type
*type
)
1340 type
= desc_base_type (type
);
1342 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
1343 return TYPE_FIELD_BITSIZE (type
, 1);
1345 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type
, 1)));
1348 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
1349 pointer to one, the type of its array data (a
1350 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
1351 ada_type_of_array to get an array type with bounds data. */
1353 static struct type
*
1354 desc_data_type (struct type
*type
)
1356 type
= desc_base_type (type
);
1358 /* NOTE: The following is bogus; see comment in desc_bounds. */
1359 if (is_thin_pntr (type
))
1360 return lookup_pointer_type
1361 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
1362 else if (is_thick_pntr (type
))
1363 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
1368 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
1371 static struct value
*
1372 desc_data (struct value
*arr
)
1374 struct type
*type
= VALUE_TYPE (arr
);
1375 if (is_thin_pntr (type
))
1376 return thin_data_pntr (arr
);
1377 else if (is_thick_pntr (type
))
1378 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
1379 "Bad GNAT array descriptor");
1385 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1386 position of the field containing the address of the data. */
1389 fat_pntr_data_bitpos (struct type
*type
)
1391 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
1394 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
1395 size of the field containing the address of the data. */
1398 fat_pntr_data_bitsize (struct type
*type
)
1400 type
= desc_base_type (type
);
1402 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
1403 return TYPE_FIELD_BITSIZE (type
, 0);
1405 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
1408 /* If BOUNDS is an array-bounds structure (or pointer to one), return
1409 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1410 bound, if WHICH is 1. The first bound is I=1. */
1412 static struct value
*
1413 desc_one_bound (struct value
*bounds
, int i
, int which
)
1415 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
1416 "Bad GNAT array descriptor bounds");
1419 /* If BOUNDS is an array-bounds structure type, return the bit position
1420 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1421 bound, if WHICH is 1. The first bound is I=1. */
1424 desc_bound_bitpos (struct type
*type
, int i
, int which
)
1426 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
1429 /* If BOUNDS is an array-bounds structure type, return the bit field size
1430 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
1431 bound, if WHICH is 1. The first bound is I=1. */
1434 desc_bound_bitsize (struct type
*type
, int i
, int which
)
1436 type
= desc_base_type (type
);
1438 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
1439 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
1441 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
1444 /* If TYPE is the type of an array-bounds structure, the type of its
1445 Ith bound (numbering from 1). Otherwise, NULL. */
1447 static struct type
*
1448 desc_index_type (struct type
*type
, int i
)
1450 type
= desc_base_type (type
);
1452 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1453 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
1458 /* The number of index positions in the array-bounds type TYPE.
1459 Return 0 if TYPE is NULL. */
1462 desc_arity (struct type
*type
)
1464 type
= desc_base_type (type
);
1467 return TYPE_NFIELDS (type
) / 2;
1471 /* Non-zero iff TYPE is a simple array type (not a pointer to one) or
1472 an array descriptor type (representing an unconstrained array
1476 ada_is_direct_array_type (struct type
*type
)
1480 CHECK_TYPEDEF (type
);
1481 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1482 || ada_is_array_descriptor_type (type
));
1485 /* Non-zero iff TYPE is a simple array type or pointer to one. */
1488 ada_is_simple_array_type (struct type
*type
)
1492 CHECK_TYPEDEF (type
);
1493 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1494 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1495 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1498 /* Non-zero iff TYPE belongs to a GNAT array descriptor. */
1501 ada_is_array_descriptor_type (struct type
*type
)
1503 struct type
*data_type
= desc_data_type (type
);
1507 CHECK_TYPEDEF (type
);
1510 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1511 && TYPE_TARGET_TYPE (data_type
) != NULL
1512 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1513 || TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1514 && desc_arity (desc_bounds_type (type
)) > 0;
1517 /* Non-zero iff type is a partially mal-formed GNAT array
1518 descriptor. FIXME: This is to compensate for some problems with
1519 debugging output from GNAT. Re-examine periodically to see if it
1523 ada_is_bogus_array_descriptor (struct type
*type
)
1527 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1528 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1529 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1530 && !ada_is_array_descriptor_type (type
);
1534 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1535 (fat pointer) returns the type of the array data described---specifically,
1536 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1537 in from the descriptor; otherwise, they are left unspecified. If
1538 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1539 returns NULL. The result is simply the type of ARR if ARR is not
1542 ada_type_of_array (struct value
*arr
, int bounds
)
1544 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1545 return decode_packed_array_type (VALUE_TYPE (arr
));
1547 if (!ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1548 return VALUE_TYPE (arr
);
1552 check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1555 struct type
*elt_type
;
1557 struct value
*descriptor
;
1558 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1560 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1561 arity
= ada_array_arity (VALUE_TYPE (arr
));
1563 if (elt_type
== NULL
|| arity
== 0)
1564 return check_typedef (VALUE_TYPE (arr
));
1566 descriptor
= desc_bounds (arr
);
1567 if (value_as_long (descriptor
) == 0)
1571 struct type
*range_type
= alloc_type (objf
);
1572 struct type
*array_type
= alloc_type (objf
);
1573 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1574 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1577 create_range_type (range_type
, VALUE_TYPE (low
),
1578 (int) value_as_long (low
),
1579 (int) value_as_long (high
));
1580 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1583 return lookup_pointer_type (elt_type
);
1587 /* If ARR does not represent an array, returns ARR unchanged.
1588 Otherwise, returns either a standard GDB array with bounds set
1589 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1590 GDB array. Returns NULL if ARR is a null fat pointer. */
1593 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1595 if (ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1597 struct type
*arrType
= ada_type_of_array (arr
, 1);
1598 if (arrType
== NULL
)
1600 return value_cast (arrType
, value_copy (desc_data (arr
)));
1602 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1603 return decode_packed_array (arr
);
1608 /* If ARR does not represent an array, returns ARR unchanged.
1609 Otherwise, returns a standard GDB array describing ARR (which may
1610 be ARR itself if it already is in the proper form). */
1612 static struct value
*
1613 ada_coerce_to_simple_array (struct value
*arr
)
1615 if (ada_is_array_descriptor_type (VALUE_TYPE (arr
)))
1617 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1619 error ("Bounds unavailable for null array pointer.");
1620 return value_ind (arrVal
);
1622 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1623 return decode_packed_array (arr
);
1628 /* If TYPE represents a GNAT array type, return it translated to an
1629 ordinary GDB array type (possibly with BITSIZE fields indicating
1630 packing). For other types, is the identity. */
1633 ada_coerce_to_simple_array_type (struct type
*type
)
1635 struct value
*mark
= value_mark ();
1636 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1637 struct type
*result
;
1638 VALUE_TYPE (dummy
) = type
;
1639 result
= ada_type_of_array (dummy
, 0);
1640 value_free_to_mark (mark
);
1644 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1647 ada_is_packed_array_type (struct type
*type
)
1651 type
= desc_base_type (type
);
1652 CHECK_TYPEDEF (type
);
1654 ada_type_name (type
) != NULL
1655 && strstr (ada_type_name (type
), "___XP") != NULL
;
1658 /* Given that TYPE is a standard GDB array type with all bounds filled
1659 in, and that the element size of its ultimate scalar constituents
1660 (that is, either its elements, or, if it is an array of arrays, its
1661 elements' elements, etc.) is *ELT_BITS, return an identical type,
1662 but with the bit sizes of its elements (and those of any
1663 constituent arrays) recorded in the BITSIZE components of its
1664 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1667 static struct type
*
1668 packed_array_type (struct type
*type
, long *elt_bits
)
1670 struct type
*new_elt_type
;
1671 struct type
*new_type
;
1672 LONGEST low_bound
, high_bound
;
1674 CHECK_TYPEDEF (type
);
1675 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1678 new_type
= alloc_type (TYPE_OBJFILE (type
));
1679 new_elt_type
= packed_array_type (check_typedef (TYPE_TARGET_TYPE (type
)),
1681 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1682 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1683 TYPE_NAME (new_type
) = ada_type_name (type
);
1685 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1686 &low_bound
, &high_bound
) < 0)
1687 low_bound
= high_bound
= 0;
1688 if (high_bound
< low_bound
)
1689 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1692 *elt_bits
*= (high_bound
- low_bound
+ 1);
1693 TYPE_LENGTH (new_type
) =
1694 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1697 TYPE_FLAGS (new_type
) |= TYPE_FLAG_FIXED_INSTANCE
;
1701 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE). */
1703 static struct type
*
1704 decode_packed_array_type (struct type
*type
)
1707 struct block
**blocks
;
1708 const char *raw_name
= ada_type_name (check_typedef (type
));
1709 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1710 char *tail
= strstr (raw_name
, "___XP");
1711 struct type
*shadow_type
;
1715 type
= desc_base_type (type
);
1717 memcpy (name
, raw_name
, tail
- raw_name
);
1718 name
[tail
- raw_name
] = '\000';
1720 sym
= standard_lookup (name
, get_selected_block (0), VAR_DOMAIN
);
1721 if (sym
== NULL
|| SYMBOL_TYPE (sym
) == NULL
)
1723 lim_warning ("could not find bounds information on packed array", 0);
1726 shadow_type
= SYMBOL_TYPE (sym
);
1728 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1730 lim_warning ("could not understand bounds information on packed array",
1735 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1738 ("could not understand bit size information on packed array", 0);
1742 return packed_array_type (shadow_type
, &bits
);
1745 /* Given that ARR is a struct value *indicating a GNAT packed array,
1746 returns a simple array that denotes that array. Its type is a
1747 standard GDB array type except that the BITSIZEs of the array
1748 target types are set to the number of bits in each element, and the
1749 type length is set appropriately. */
1751 static struct value
*
1752 decode_packed_array (struct value
*arr
)
1756 arr
= ada_coerce_ref (arr
);
1757 if (TYPE_CODE (VALUE_TYPE (arr
)) == TYPE_CODE_PTR
)
1758 arr
= ada_value_ind (arr
);
1760 type
= decode_packed_array_type (VALUE_TYPE (arr
));
1763 error ("can't unpack array");
1766 return coerce_unspec_val_to_type (arr
, type
);
1770 /* The value of the element of packed array ARR at the ARITY indices
1771 given in IND. ARR must be a simple array. */
1773 static struct value
*
1774 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1777 int bits
, elt_off
, bit_off
;
1778 long elt_total_bit_offset
;
1779 struct type
*elt_type
;
1783 elt_total_bit_offset
= 0;
1784 elt_type
= check_typedef (VALUE_TYPE (arr
));
1785 for (i
= 0; i
< arity
; i
+= 1)
1787 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1788 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1790 ("attempt to do packed indexing of something other than a packed array");
1793 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1794 LONGEST lowerbound
, upperbound
;
1797 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1799 lim_warning ("don't know bounds of array", 0);
1800 lowerbound
= upperbound
= 0;
1803 idx
= value_as_long (value_pos_atr (ind
[i
]));
1804 if (idx
< lowerbound
|| idx
> upperbound
)
1805 lim_warning ("packed array index %ld out of bounds", (long) idx
);
1806 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1807 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1808 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
1811 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1812 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1814 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1816 if (VALUE_LVAL (arr
) == lval_internalvar
)
1817 VALUE_LVAL (v
) = lval_internalvar_component
;
1819 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1823 /* Non-zero iff TYPE includes negative integer values. */
1826 has_negatives (struct type
*type
)
1828 switch (TYPE_CODE (type
))
1833 return !TYPE_UNSIGNED (type
);
1834 case TYPE_CODE_RANGE
:
1835 return TYPE_LOW_BOUND (type
) < 0;
1840 /* Create a new value of type TYPE from the contents of OBJ starting
1841 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1842 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1843 assigning through the result will set the field fetched from.
1844 VALADDR is ignored unless OBJ is NULL, in which case,
1845 VALADDR+OFFSET must address the start of storage containing the
1846 packed value. The value returned in this case is never an lval.
1847 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1850 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1851 int bit_offset
, int bit_size
,
1855 int src
, /* Index into the source area */
1856 targ
, /* Index into the target area */
1857 srcBitsLeft
, /* Number of source bits left to move */
1858 nsrc
, ntarg
, /* Number of source and target bytes */
1859 unusedLS
, /* Number of bits in next significant
1860 byte of source that are unused */
1861 accumSize
; /* Number of meaningful bits in accum */
1862 unsigned char *bytes
; /* First byte containing data to unpack */
1863 unsigned char *unpacked
;
1864 unsigned long accum
; /* Staging area for bits being transferred */
1866 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1867 /* Transmit bytes from least to most significant; delta is the direction
1868 the indices move. */
1869 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1871 CHECK_TYPEDEF (type
);
1875 v
= allocate_value (type
);
1876 bytes
= (unsigned char *) (valaddr
+ offset
);
1878 else if (VALUE_LAZY (obj
))
1881 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1882 bytes
= (unsigned char *) alloca (len
);
1883 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1887 v
= allocate_value (type
);
1888 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1893 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1894 if (VALUE_LVAL (obj
) == lval_internalvar
)
1895 VALUE_LVAL (v
) = lval_internalvar_component
;
1896 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1897 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1898 VALUE_BITSIZE (v
) = bit_size
;
1899 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1901 VALUE_ADDRESS (v
) += 1;
1902 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1906 VALUE_BITSIZE (v
) = bit_size
;
1907 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1909 srcBitsLeft
= bit_size
;
1911 ntarg
= TYPE_LENGTH (type
);
1915 memset (unpacked
, 0, TYPE_LENGTH (type
));
1918 else if (BITS_BIG_ENDIAN
)
1921 if (has_negatives (type
)
1922 && ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1926 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1929 switch (TYPE_CODE (type
))
1931 case TYPE_CODE_ARRAY
:
1932 case TYPE_CODE_UNION
:
1933 case TYPE_CODE_STRUCT
:
1934 /* Non-scalar values must be aligned at a byte boundary... */
1936 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1937 /* ... And are placed at the beginning (most-significant) bytes
1943 targ
= TYPE_LENGTH (type
) - 1;
1949 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1952 unusedLS
= bit_offset
;
1955 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1962 /* Mask for removing bits of the next source byte that are not
1963 part of the value. */
1964 unsigned int unusedMSMask
=
1965 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1967 /* Sign-extend bits for this byte. */
1968 unsigned int signMask
= sign
& ~unusedMSMask
;
1970 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1971 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1972 if (accumSize
>= HOST_CHAR_BIT
)
1974 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1975 accumSize
-= HOST_CHAR_BIT
;
1976 accum
>>= HOST_CHAR_BIT
;
1980 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1987 accum
|= sign
<< accumSize
;
1988 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1989 accumSize
-= HOST_CHAR_BIT
;
1990 accum
>>= HOST_CHAR_BIT
;
1998 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1999 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
2002 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
2004 unsigned int accum
, mask
;
2005 int accum_bits
, chunk_size
;
2007 target
+= targ_offset
/ HOST_CHAR_BIT
;
2008 targ_offset
%= HOST_CHAR_BIT
;
2009 source
+= src_offset
/ HOST_CHAR_BIT
;
2010 src_offset
%= HOST_CHAR_BIT
;
2011 if (BITS_BIG_ENDIAN
)
2013 accum
= (unsigned char) *source
;
2015 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2020 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
2021 accum_bits
+= HOST_CHAR_BIT
;
2023 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2026 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
2027 mask
= ((1 << chunk_size
) - 1) << unused_right
;
2030 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
2032 accum_bits
-= chunk_size
;
2039 accum
= (unsigned char) *source
>> src_offset
;
2041 accum_bits
= HOST_CHAR_BIT
- src_offset
;
2045 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
2046 accum_bits
+= HOST_CHAR_BIT
;
2048 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
2051 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
2052 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
2054 accum_bits
-= chunk_size
;
2055 accum
>>= chunk_size
;
2063 /* Store the contents of FROMVAL into the location of TOVAL.
2064 Return a new value with the location of TOVAL and contents of
2065 FROMVAL. Handles assignment into packed fields that have
2066 floating-point or non-scalar types. */
2068 static struct value
*
2069 ada_value_assign (struct value
*toval
, struct value
*fromval
)
2071 struct type
*type
= VALUE_TYPE (toval
);
2072 int bits
= VALUE_BITSIZE (toval
);
2074 if (!toval
->modifiable
)
2075 error ("Left operand of assignment is not a modifiable lvalue.");
2079 if (VALUE_LVAL (toval
) == lval_memory
2081 && (TYPE_CODE (type
) == TYPE_CODE_FLT
2082 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
2085 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
2086 char *buffer
= (char *) alloca (len
);
2089 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
2090 fromval
= value_cast (type
, fromval
);
2092 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
2093 if (BITS_BIG_ENDIAN
)
2094 move_bits (buffer
, VALUE_BITPOS (toval
),
2095 VALUE_CONTENTS (fromval
),
2096 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
-
2099 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
2101 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
,
2104 val
= value_copy (toval
);
2105 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
2106 TYPE_LENGTH (type
));
2107 VALUE_TYPE (val
) = type
;
2112 return value_assign (toval
, fromval
);
2116 /* The value of the element of array ARR at the ARITY indices given in IND.
2117 ARR may be either a simple array, GNAT array descriptor, or pointer
2121 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
2125 struct type
*elt_type
;
2127 elt
= ada_coerce_to_simple_array (arr
);
2129 elt_type
= check_typedef (VALUE_TYPE (elt
));
2130 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
2131 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
2132 return value_subscript_packed (elt
, arity
, ind
);
2134 for (k
= 0; k
< arity
; k
+= 1)
2136 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
2137 error ("too many subscripts (%d expected)", k
);
2138 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
2143 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
2144 value of the element of *ARR at the ARITY indices given in
2145 IND. Does not read the entire array into memory. */
2148 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
2153 for (k
= 0; k
< arity
; k
+= 1)
2158 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
2159 error ("too many subscripts (%d expected)", k
);
2160 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
2162 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
2163 idx
= value_pos_atr (ind
[k
]);
2165 idx
= value_sub (idx
, value_from_longest (builtin_type_int
, lwb
));
2166 arr
= value_add (arr
, idx
);
2167 type
= TYPE_TARGET_TYPE (type
);
2170 return value_ind (arr
);
2173 /* Given that ARRAY_PTR is a pointer or reference to an array of type TYPE (the
2174 actual type of ARRAY_PTR is ignored), returns a reference to
2175 the Ada slice of HIGH-LOW+1 elements starting at index LOW. The lower
2176 bound of this array is LOW, as per Ada rules. */
2177 static struct value
*
2178 ada_value_slice_ptr (struct value
*array_ptr
, struct type
*type
,
2181 CORE_ADDR base
= value_as_address (array_ptr
)
2182 + ((low
- TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type
)))
2183 * TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
2184 struct type
*index_type
=
2185 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (type
)),
2187 struct type
*slice_type
=
2188 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2189 return value_from_pointer (lookup_reference_type (slice_type
), base
);
2193 static struct value
*
2194 ada_value_slice (struct value
*array
, int low
, int high
)
2196 struct type
*type
= VALUE_TYPE (array
);
2197 struct type
*index_type
=
2198 create_range_type (NULL
, TYPE_INDEX_TYPE (type
), low
, high
);
2199 struct type
*slice_type
=
2200 create_array_type (NULL
, TYPE_TARGET_TYPE (type
), index_type
);
2201 return value_cast (slice_type
, value_slice (array
, low
, high
-low
+1));
2204 /* If type is a record type in the form of a standard GNAT array
2205 descriptor, returns the number of dimensions for type. If arr is a
2206 simple array, returns the number of "array of"s that prefix its
2207 type designation. Otherwise, returns 0. */
2210 ada_array_arity (struct type
*type
)
2217 type
= desc_base_type (type
);
2220 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2221 return desc_arity (desc_bounds_type (type
));
2223 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2226 type
= check_typedef (TYPE_TARGET_TYPE (type
));
2232 /* If TYPE is a record type in the form of a standard GNAT array
2233 descriptor or a simple array type, returns the element type for
2234 TYPE after indexing by NINDICES indices, or by all indices if
2235 NINDICES is -1. Otherwise, returns NULL. */
2238 ada_array_element_type (struct type
*type
, int nindices
)
2240 type
= desc_base_type (type
);
2242 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2245 struct type
*p_array_type
;
2247 p_array_type
= desc_data_type (type
);
2249 k
= ada_array_arity (type
);
2253 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2254 if (nindices
>= 0 && k
> nindices
)
2256 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2257 while (k
> 0 && p_array_type
!= NULL
)
2259 p_array_type
= check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2262 return p_array_type
;
2264 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2266 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2268 type
= TYPE_TARGET_TYPE (type
);
2277 /* The type of nth index in arrays of given type (n numbering from 1).
2278 Does not examine memory. */
2281 ada_index_type (struct type
*type
, int n
)
2283 struct type
*result_type
;
2285 type
= desc_base_type (type
);
2287 if (n
> ada_array_arity (type
))
2290 if (ada_is_simple_array_type (type
))
2294 for (i
= 1; i
< n
; i
+= 1)
2295 type
= TYPE_TARGET_TYPE (type
);
2296 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2297 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2298 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2299 perhaps stabsread.c would make more sense. */
2300 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2301 result_type
= builtin_type_int
;
2306 return desc_index_type (desc_bounds_type (type
), n
);
2309 /* Given that arr is an array type, returns the lower bound of the
2310 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2311 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2312 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2313 bounds type. It works for other arrays with bounds supplied by
2314 run-time quantities other than discriminants. */
2317 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2318 struct type
** typep
)
2321 struct type
*index_type_desc
;
2323 if (ada_is_packed_array_type (arr_type
))
2324 arr_type
= decode_packed_array_type (arr_type
);
2326 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2329 *typep
= builtin_type_int
;
2330 return (LONGEST
) - which
;
2333 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2334 type
= TYPE_TARGET_TYPE (arr_type
);
2338 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2339 if (index_type_desc
== NULL
)
2341 struct type
*range_type
;
2342 struct type
*index_type
;
2346 type
= TYPE_TARGET_TYPE (type
);
2350 range_type
= TYPE_INDEX_TYPE (type
);
2351 index_type
= TYPE_TARGET_TYPE (range_type
);
2352 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2353 index_type
= builtin_type_long
;
2355 *typep
= index_type
;
2357 (LONGEST
) (which
== 0
2358 ? TYPE_LOW_BOUND (range_type
)
2359 : TYPE_HIGH_BOUND (range_type
));
2363 struct type
*index_type
=
2364 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2365 NULL
, TYPE_OBJFILE (arr_type
));
2367 *typep
= TYPE_TARGET_TYPE (index_type
);
2369 (LONGEST
) (which
== 0
2370 ? TYPE_LOW_BOUND (index_type
)
2371 : TYPE_HIGH_BOUND (index_type
));
2375 /* Given that arr is an array value, returns the lower bound of the
2376 nth index (numbering from 1) if which is 0, and the upper bound if
2377 which is 1. This routine will also work for arrays with bounds
2378 supplied by run-time quantities other than discriminants. */
2381 ada_array_bound (struct value
*arr
, int n
, int which
)
2383 struct type
*arr_type
= VALUE_TYPE (arr
);
2385 if (ada_is_packed_array_type (arr_type
))
2386 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2387 else if (ada_is_simple_array_type (arr_type
))
2390 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2391 return value_from_longest (type
, v
);
2394 return desc_one_bound (desc_bounds (arr
), n
, which
);
2397 /* Given that arr is an array value, returns the length of the
2398 nth index. This routine will also work for arrays with bounds
2399 supplied by run-time quantities other than discriminants.
2400 Does not work for arrays indexed by enumeration types with representation
2401 clauses at the moment. */
2404 ada_array_length (struct value
*arr
, int n
)
2406 struct type
*arr_type
= check_typedef (VALUE_TYPE (arr
));
2408 if (ada_is_packed_array_type (arr_type
))
2409 return ada_array_length (decode_packed_array (arr
), n
);
2411 if (ada_is_simple_array_type (arr_type
))
2415 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2416 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2417 return value_from_longest (type
, v
);
2421 value_from_longest (builtin_type_ada_int
,
2422 value_as_long (desc_one_bound (desc_bounds (arr
),
2424 - value_as_long (desc_one_bound (desc_bounds (arr
),
2428 /* An empty array whose type is that of ARR_TYPE (an array type),
2429 with bounds LOW to LOW-1. */
2431 static struct value
*
2432 empty_array (struct type
*arr_type
, int low
)
2434 struct type
*index_type
=
2435 create_range_type (NULL
, TYPE_TARGET_TYPE (TYPE_INDEX_TYPE (arr_type
)),
2437 struct type
*elt_type
= ada_array_element_type (arr_type
, 1);
2438 return allocate_value (create_array_type (NULL
, elt_type
, index_type
));
2442 /* Name resolution */
2444 /* The "decoded" name for the user-definable Ada operator corresponding
2448 ada_decoded_op_name (enum exp_opcode op
)
2452 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2454 if (ada_opname_table
[i
].op
== op
)
2455 return ada_opname_table
[i
].decoded
;
2457 error ("Could not find operator name for opcode");
2461 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2462 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2463 undefined namespace) and converts operators that are
2464 user-defined into appropriate function calls. If CONTEXT_TYPE is
2465 non-null, it provides a preferred result type [at the moment, only
2466 type void has any effect---causing procedures to be preferred over
2467 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2468 return type is preferred. May change (expand) *EXP. */
2471 resolve (struct expression
**expp
, int void_context_p
)
2475 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2478 /* Resolve the operator of the subexpression beginning at
2479 position *POS of *EXPP. "Resolving" consists of replacing
2480 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2481 with their resolutions, replacing built-in operators with
2482 function calls to user-defined operators, where appropriate, and,
2483 when DEPROCEDURE_P is non-zero, converting function-valued variables
2484 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2485 are as in ada_resolve, above. */
2487 static struct value
*
2488 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2489 struct type
*context_type
)
2493 struct expression
*exp
; /* Convenience: == *expp. */
2494 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2495 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2496 int nargs
; /* Number of operands. */
2502 /* Pass one: resolve operands, saving their types and updating *pos. */
2506 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2507 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2512 resolve_subexp (expp
, pos
, 0, NULL
);
2514 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2519 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2524 resolve_subexp (expp
, pos
, 0, NULL
);
2527 case OP_ATR_MODULUS
:
2557 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2559 resolve_subexp (expp
, pos
, 1, NULL
);
2561 resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2579 case BINOP_LOGICAL_AND
:
2580 case BINOP_LOGICAL_OR
:
2581 case BINOP_BITWISE_AND
:
2582 case BINOP_BITWISE_IOR
:
2583 case BINOP_BITWISE_XOR
:
2586 case BINOP_NOTEQUAL
:
2593 case BINOP_SUBSCRIPT
:
2601 case UNOP_LOGICAL_NOT
:
2618 case OP_INTERNALVAR
:
2627 case STRUCTOP_STRUCT
:
2628 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2634 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2639 case TERNOP_IN_RANGE
:
2644 case BINOP_IN_BOUNDS
:
2650 error ("Unexpected operator during name resolution");
2653 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2654 for (i
= 0; i
< nargs
; i
+= 1)
2655 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2659 /* Pass two: perform any resolution on principal operator. */
2666 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2668 struct ada_symbol_info
*candidates
;
2672 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2673 (exp
->elts
[pc
+ 2].symbol
),
2674 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2677 if (n_candidates
> 1)
2679 /* Types tend to get re-introduced locally, so if there
2680 are any local symbols that are not types, first filter
2683 for (j
= 0; j
< n_candidates
; j
+= 1)
2684 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2690 case LOC_REGPARM_ADDR
:
2694 case LOC_BASEREG_ARG
:
2696 case LOC_COMPUTED_ARG
:
2702 if (j
< n_candidates
)
2705 while (j
< n_candidates
)
2707 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2709 candidates
[j
] = candidates
[n_candidates
- 1];
2718 if (n_candidates
== 0)
2719 error ("No definition found for %s",
2720 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2721 else if (n_candidates
== 1)
2723 else if (deprocedure_p
2724 && !is_nonfunction (candidates
, n_candidates
))
2726 i
= ada_resolve_function
2727 (candidates
, n_candidates
, NULL
, 0,
2728 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2731 error ("Could not find a match for %s",
2732 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2736 printf_filtered ("Multiple matches for %s\n",
2737 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2738 user_select_syms (candidates
, n_candidates
, 1);
2742 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2743 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2744 if (innermost_block
== NULL
2745 || contained_in (candidates
[i
].block
, innermost_block
))
2746 innermost_block
= candidates
[i
].block
;
2750 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2753 replace_operator_with_call (expp
, pc
, 0, 0,
2754 exp
->elts
[pc
+ 2].symbol
,
2755 exp
->elts
[pc
+ 1].block
);
2762 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2763 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2765 struct ada_symbol_info
*candidates
;
2769 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2770 (exp
->elts
[pc
+ 5].symbol
),
2771 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2773 if (n_candidates
== 1)
2777 i
= ada_resolve_function
2778 (candidates
, n_candidates
,
2780 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2783 error ("Could not find a match for %s",
2784 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2787 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2788 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2789 if (innermost_block
== NULL
2790 || contained_in (candidates
[i
].block
, innermost_block
))
2791 innermost_block
= candidates
[i
].block
;
2802 case BINOP_BITWISE_AND
:
2803 case BINOP_BITWISE_IOR
:
2804 case BINOP_BITWISE_XOR
:
2806 case BINOP_NOTEQUAL
:
2814 case UNOP_LOGICAL_NOT
:
2816 if (possible_user_operator_p (op
, argvec
))
2818 struct ada_symbol_info
*candidates
;
2822 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2823 (struct block
*) NULL
, VAR_DOMAIN
,
2825 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2826 ada_decoded_op_name (op
), NULL
);
2830 replace_operator_with_call (expp
, pc
, nargs
, 1,
2831 candidates
[i
].sym
, candidates
[i
].block
);
2841 return evaluate_subexp_type (exp
, pos
);
2844 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2845 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2846 a non-pointer. A type of 'void' (which is never a valid expression type)
2847 by convention matches anything. */
2848 /* The term "match" here is rather loose. The match is heuristic and
2849 liberal. FIXME: TOO liberal, in fact. */
2852 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2854 CHECK_TYPEDEF (ftype
);
2855 CHECK_TYPEDEF (atype
);
2857 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2858 ftype
= TYPE_TARGET_TYPE (ftype
);
2859 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2860 atype
= TYPE_TARGET_TYPE (atype
);
2862 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2863 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2866 switch (TYPE_CODE (ftype
))
2871 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2872 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2873 TYPE_TARGET_TYPE (atype
), 0);
2876 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2878 case TYPE_CODE_ENUM
:
2879 case TYPE_CODE_RANGE
:
2880 switch (TYPE_CODE (atype
))
2883 case TYPE_CODE_ENUM
:
2884 case TYPE_CODE_RANGE
:
2890 case TYPE_CODE_ARRAY
:
2891 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2892 || ada_is_array_descriptor_type (atype
));
2894 case TYPE_CODE_STRUCT
:
2895 if (ada_is_array_descriptor_type (ftype
))
2896 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2897 || ada_is_array_descriptor_type (atype
));
2899 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2900 && !ada_is_array_descriptor_type (atype
));
2902 case TYPE_CODE_UNION
:
2904 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2908 /* Return non-zero if the formals of FUNC "sufficiently match" the
2909 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2910 may also be an enumeral, in which case it is treated as a 0-
2911 argument function. */
2914 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2917 struct type
*func_type
= SYMBOL_TYPE (func
);
2919 if (SYMBOL_CLASS (func
) == LOC_CONST
2920 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2921 return (n_actuals
== 0);
2922 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2925 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2928 for (i
= 0; i
< n_actuals
; i
+= 1)
2930 if (actuals
[i
] == NULL
)
2934 struct type
*ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2935 struct type
*atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2937 if (!ada_type_match (ftype
, atype
, 1))
2944 /* False iff function type FUNC_TYPE definitely does not produce a value
2945 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2946 FUNC_TYPE is not a valid function type with a non-null return type
2947 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2950 return_match (struct type
*func_type
, struct type
*context_type
)
2952 struct type
*return_type
;
2954 if (func_type
== NULL
)
2957 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2958 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2960 return_type
= base_type (func_type
);
2961 if (return_type
== NULL
)
2964 context_type
= base_type (context_type
);
2966 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2967 return context_type
== NULL
|| return_type
== context_type
;
2968 else if (context_type
== NULL
)
2969 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2971 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2975 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
2976 function (if any) that matches the types of the NARGS arguments in
2977 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2978 that returns that type, then eliminate matches that don't. If
2979 CONTEXT_TYPE is void and there is at least one match that does not
2980 return void, eliminate all matches that do.
2982 Asks the user if there is more than one match remaining. Returns -1
2983 if there is no such symbol or none is selected. NAME is used
2984 solely for messages. May re-arrange and modify SYMS in
2985 the process; the index returned is for the modified vector. */
2988 ada_resolve_function (struct ada_symbol_info syms
[],
2989 int nsyms
, struct value
**args
, int nargs
,
2990 const char *name
, struct type
*context_type
)
2993 int m
; /* Number of hits */
2994 struct type
*fallback
;
2995 struct type
*return_type
;
2997 return_type
= context_type
;
2998 if (context_type
== NULL
)
2999 fallback
= builtin_type_void
;
3006 for (k
= 0; k
< nsyms
; k
+= 1)
3008 struct type
*type
= check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
3010 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
3011 && return_match (type
, return_type
))
3017 if (m
> 0 || return_type
== fallback
)
3020 return_type
= fallback
;
3027 printf_filtered ("Multiple matches for %s\n", name
);
3028 user_select_syms (syms
, m
, 1);
3034 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3035 in a listing of choices during disambiguation (see sort_choices, below).
3036 The idea is that overloadings of a subprogram name from the
3037 same package should sort in their source order. We settle for ordering
3038 such symbols by their trailing number (__N or $N). */
3041 encoded_ordered_before (char *N0
, char *N1
)
3045 else if (N0
== NULL
)
3050 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3052 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3054 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3055 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3059 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3062 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3064 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3065 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3067 return (strcmp (N0
, N1
) < 0);
3071 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3075 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3078 for (i
= 1; i
< nsyms
; i
+= 1)
3080 struct ada_symbol_info sym
= syms
[i
];
3083 for (j
= i
- 1; j
>= 0; j
-= 1)
3085 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3086 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3088 syms
[j
+ 1] = syms
[j
];
3094 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3095 by asking the user (if necessary), returning the number selected,
3096 and setting the first elements of SYMS items. Error if no symbols
3099 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3100 to be re-integrated one of these days. */
3103 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3106 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3108 int first_choice
= (max_results
== 1) ? 1 : 2;
3110 if (max_results
< 1)
3111 error ("Request to select 0 symbols!");
3115 printf_unfiltered ("[0] cancel\n");
3116 if (max_results
> 1)
3117 printf_unfiltered ("[1] all\n");
3119 sort_choices (syms
, nsyms
);
3121 for (i
= 0; i
< nsyms
; i
+= 1)
3123 if (syms
[i
].sym
== NULL
)
3126 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3128 struct symtab_and_line sal
=
3129 find_function_start_sal (syms
[i
].sym
, 1);
3130 printf_unfiltered ("[%d] %s at %s:%d\n", i
+ first_choice
,
3131 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3133 ? "<no source file available>"
3134 : sal
.symtab
->filename
), sal
.line
);
3140 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3141 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3142 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3143 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3145 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3146 printf_unfiltered ("[%d] %s at %s:%d\n",
3148 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3149 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3150 else if (is_enumeral
3151 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3153 printf_unfiltered ("[%d] ", i
+ first_choice
);
3154 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3156 printf_unfiltered ("'(%s) (enumeral)\n",
3157 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3159 else if (symtab
!= NULL
)
3160 printf_unfiltered (is_enumeral
3161 ? "[%d] %s in %s (enumeral)\n"
3162 : "[%d] %s at %s:?\n",
3164 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3167 printf_unfiltered (is_enumeral
3168 ? "[%d] %s (enumeral)\n"
3171 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3175 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3178 for (i
= 0; i
< n_chosen
; i
+= 1)
3179 syms
[i
] = syms
[chosen
[i
]];
3184 /* Read and validate a set of numeric choices from the user in the
3185 range 0 .. N_CHOICES-1. Place the results in increasing
3186 order in CHOICES[0 .. N-1], and return N.
3188 The user types choices as a sequence of numbers on one line
3189 separated by blanks, encoding them as follows:
3191 + A choice of 0 means to cancel the selection, throwing an error.
3192 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3193 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3195 The user is not allowed to choose more than MAX_RESULTS values.
3197 ANNOTATION_SUFFIX, if present, is used to annotate the input
3198 prompts (for use with the -f switch). */
3201 get_selections (int *choices
, int n_choices
, int max_results
,
3202 int is_all_choice
, char *annotation_suffix
)
3207 int first_choice
= is_all_choice
? 2 : 1;
3209 prompt
= getenv ("PS2");
3213 printf_unfiltered ("%s ", prompt
);
3214 gdb_flush (gdb_stdout
);
3216 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3219 error_no_arg ("one or more choice numbers");
3223 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3224 order, as given in args. Choices are validated. */
3230 while (isspace (*args
))
3232 if (*args
== '\0' && n_chosen
== 0)
3233 error_no_arg ("one or more choice numbers");
3234 else if (*args
== '\0')
3237 choice
= strtol (args
, &args2
, 10);
3238 if (args
== args2
|| choice
< 0
3239 || choice
> n_choices
+ first_choice
- 1)
3240 error ("Argument must be choice number");
3244 error ("cancelled");
3246 if (choice
< first_choice
)
3248 n_chosen
= n_choices
;
3249 for (j
= 0; j
< n_choices
; j
+= 1)
3253 choice
-= first_choice
;
3255 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3259 if (j
< 0 || choice
!= choices
[j
])
3262 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3263 choices
[k
+ 1] = choices
[k
];
3264 choices
[j
+ 1] = choice
;
3269 if (n_chosen
> max_results
)
3270 error ("Select no more than %d of the above", max_results
);
3275 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3276 on the function identified by SYM and BLOCK, and taking NARGS
3277 arguments. Update *EXPP as needed to hold more space. */
3280 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3281 int oplen
, struct symbol
*sym
,
3282 struct block
*block
)
3284 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3285 symbol, -oplen for operator being replaced). */
3286 struct expression
*newexp
= (struct expression
*)
3287 xmalloc (sizeof (struct expression
)
3288 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3289 struct expression
*exp
= *expp
;
3291 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3292 newexp
->language_defn
= exp
->language_defn
;
3293 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3294 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3295 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3297 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3298 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3300 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3301 newexp
->elts
[pc
+ 4].block
= block
;
3302 newexp
->elts
[pc
+ 5].symbol
= sym
;
3308 /* Type-class predicates */
3310 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3314 numeric_type_p (struct type
*type
)
3320 switch (TYPE_CODE (type
))
3325 case TYPE_CODE_RANGE
:
3326 return (type
== TYPE_TARGET_TYPE (type
)
3327 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3334 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3337 integer_type_p (struct type
*type
)
3343 switch (TYPE_CODE (type
))
3347 case TYPE_CODE_RANGE
:
3348 return (type
== TYPE_TARGET_TYPE (type
)
3349 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3356 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3359 scalar_type_p (struct type
*type
)
3365 switch (TYPE_CODE (type
))
3368 case TYPE_CODE_RANGE
:
3369 case TYPE_CODE_ENUM
:
3378 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3381 discrete_type_p (struct type
*type
)
3387 switch (TYPE_CODE (type
))
3390 case TYPE_CODE_RANGE
:
3391 case TYPE_CODE_ENUM
:
3399 /* Returns non-zero if OP with operands in the vector ARGS could be
3400 a user-defined function. Errs on the side of pre-defined operators
3401 (i.e., result 0). */
3404 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3406 struct type
*type0
=
3407 (args
[0] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[0]));
3408 struct type
*type1
=
3409 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
3423 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3427 case BINOP_BITWISE_AND
:
3428 case BINOP_BITWISE_IOR
:
3429 case BINOP_BITWISE_XOR
:
3430 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3433 case BINOP_NOTEQUAL
:
3438 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3442 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3443 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3444 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3445 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3446 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3447 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
)) !=
3448 TYPE_CODE_ARRAY
))));
3451 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3455 case UNOP_LOGICAL_NOT
:
3457 return (!numeric_type_p (type0
));
3464 /* NOTE: In the following, we assume that a renaming type's name may
3465 have an ___XD suffix. It would be nice if this went away at some
3468 /* If TYPE encodes a renaming, returns the renaming suffix, which
3469 is XR for an object renaming, XRP for a procedure renaming, XRE for
3470 an exception renaming, and XRS for a subprogram renaming. Returns
3471 NULL if NAME encodes none of these. */
3474 ada_renaming_type (struct type
*type
)
3476 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3478 const char *name
= type_name_no_tag (type
);
3479 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3481 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3490 /* Return non-zero iff SYM encodes an object renaming. */
3493 ada_is_object_renaming (struct symbol
*sym
)
3495 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3496 return renaming_type
!= NULL
3497 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3500 /* Assuming that SYM encodes a non-object renaming, returns the original
3501 name of the renamed entity. The name is good until the end of
3505 ada_simple_renamed_entity (struct symbol
*sym
)
3508 const char *raw_name
;
3512 type
= SYMBOL_TYPE (sym
);
3513 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3514 error ("Improperly encoded renaming.");
3516 raw_name
= TYPE_FIELD_NAME (type
, 0);
3517 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3519 error ("Improperly encoded renaming.");
3521 result
= xmalloc (len
+ 1);
3522 strncpy (result
, raw_name
, len
);
3523 result
[len
] = '\000';
3528 /* Evaluation: Function Calls */
3530 /* Return an lvalue containing the value VAL. This is the identity on
3531 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3532 on the stack, using and updating *SP as the stack pointer, and
3533 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3535 static struct value
*
3536 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3538 CORE_ADDR old_sp
= *sp
;
3540 if (VALUE_LVAL (val
))
3543 if (DEPRECATED_STACK_ALIGN_P ())
3544 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3545 DEPRECATED_STACK_ALIGN
3546 (TYPE_LENGTH (check_typedef (VALUE_TYPE (val
)))));
3548 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3549 TYPE_LENGTH (check_typedef (VALUE_TYPE (val
))));
3551 VALUE_LVAL (val
) = lval_memory
;
3552 if (INNER_THAN (1, 2))
3553 VALUE_ADDRESS (val
) = *sp
;
3555 VALUE_ADDRESS (val
) = old_sp
;
3560 /* Return the value ACTUAL, converted to be an appropriate value for a
3561 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3562 allocating any necessary descriptors (fat pointers), or copies of
3563 values not residing in memory, updating it as needed. */
3565 static struct value
*
3566 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3569 struct type
*actual_type
= check_typedef (VALUE_TYPE (actual
));
3570 struct type
*formal_type
= check_typedef (formal_type0
);
3571 struct type
*formal_target
=
3572 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3573 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3574 struct type
*actual_target
=
3575 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3576 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3578 if (ada_is_array_descriptor_type (formal_target
)
3579 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3580 return make_array_descriptor (formal_type
, actual
, sp
);
3581 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3583 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3584 && ada_is_array_descriptor_type (actual_target
))
3585 return desc_data (actual
);
3586 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3588 if (VALUE_LVAL (actual
) != lval_memory
)
3591 actual_type
= check_typedef (VALUE_TYPE (actual
));
3592 val
= allocate_value (actual_type
);
3593 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3594 (char *) VALUE_CONTENTS (actual
),
3595 TYPE_LENGTH (actual_type
));
3596 actual
= ensure_lval (val
, sp
);
3598 return value_addr (actual
);
3601 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3602 return ada_value_ind (actual
);
3608 /* Push a descriptor of type TYPE for array value ARR on the stack at
3609 *SP, updating *SP to reflect the new descriptor. Return either
3610 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3611 to-descriptor type rather than a descriptor type), a struct value *
3612 representing a pointer to this descriptor. */
3614 static struct value
*
3615 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3617 struct type
*bounds_type
= desc_bounds_type (type
);
3618 struct type
*desc_type
= desc_base_type (type
);
3619 struct value
*descriptor
= allocate_value (desc_type
);
3620 struct value
*bounds
= allocate_value (bounds_type
);
3623 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3625 modify_general_field (VALUE_CONTENTS (bounds
),
3626 value_as_long (ada_array_bound (arr
, i
, 0)),
3627 desc_bound_bitpos (bounds_type
, i
, 0),
3628 desc_bound_bitsize (bounds_type
, i
, 0));
3629 modify_general_field (VALUE_CONTENTS (bounds
),
3630 value_as_long (ada_array_bound (arr
, i
, 1)),
3631 desc_bound_bitpos (bounds_type
, i
, 1),
3632 desc_bound_bitsize (bounds_type
, i
, 1));
3635 bounds
= ensure_lval (bounds
, sp
);
3637 modify_general_field (VALUE_CONTENTS (descriptor
),
3638 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3639 fat_pntr_data_bitpos (desc_type
),
3640 fat_pntr_data_bitsize (desc_type
));
3642 modify_general_field (VALUE_CONTENTS (descriptor
),
3643 VALUE_ADDRESS (bounds
),
3644 fat_pntr_bounds_bitpos (desc_type
),
3645 fat_pntr_bounds_bitsize (desc_type
));
3647 descriptor
= ensure_lval (descriptor
, sp
);
3649 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3650 return value_addr (descriptor
);
3656 /* Assuming a dummy frame has been established on the target, perform any
3657 conversions needed for calling function FUNC on the NARGS actual
3658 parameters in ARGS, other than standard C conversions. Does
3659 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3660 does not match the number of arguments expected. Use *SP as a
3661 stack pointer for additional data that must be pushed, updating its
3665 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3670 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3671 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3674 for (i
= 0; i
< nargs
; i
+= 1)
3676 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3679 /* Experimental Symbol Cache Module */
3681 /* This module may well have been OBE, due to improvements in the
3682 symbol-table module. So until proven otherwise, it is disabled in
3683 the submitted public code, and may be removed from all sources
3688 /* This section implements a simple, fixed-sized hash table for those
3689 Ada-mode symbols that get looked up in the course of executing the user's
3690 commands. The size is fixed on the grounds that there are not
3691 likely to be all that many symbols looked up during any given
3692 session, regardless of the size of the symbol table. If we decide
3693 to go to a resizable table, let's just use the stuff from libiberty
3696 #define HASH_SIZE 1009
3701 domain_enum
namespace;
3703 struct symtab
*symtab
;
3704 struct block
*block
;
3705 struct cache_entry
*next
;
3708 static struct obstack cache_space
;
3710 static struct cache_entry
*cache
[HASH_SIZE
];
3712 /* Clear all entries from the symbol cache. */
3715 clear_ada_sym_cache (void)
3717 obstack_free (&cache_space
, NULL
);
3718 obstack_init (&cache_space
);
3719 memset (cache
, '\000', sizeof (cache
));
3722 static struct cache_entry
**
3723 find_entry (const char *name
, domain_enum
namespace)
3725 int h
= msymbol_hash (name
) % HASH_SIZE
;
3726 struct cache_entry
**e
;
3727 for (e
= &cache
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
3729 if (namespace == (*e
)->namespace && strcmp (name
, (*e
)->name
) == 0)
3735 /* Return (in SYM) the last cached definition for global or static symbol NAME
3736 in namespace DOMAIN. Returns 1 if entry found, 0 otherwise.
3737 If SYMTAB is non-NULL, store the symbol
3738 table in which the symbol was found there, or NULL if not found.
3739 *BLOCK is set to the block in which NAME is found. */
3742 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3743 struct symbol
**sym
, struct block
**block
,
3744 struct symtab
**symtab
)
3746 struct cache_entry
**e
= find_entry (name
, namespace);
3752 *block
= (*e
)->block
;
3754 *symtab
= (*e
)->symtab
;
3758 /* Set the cached definition of NAME in DOMAIN to SYM in block
3759 BLOCK and symbol table SYMTAB. */
3762 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3763 struct block
*block
, struct symtab
*symtab
)
3765 int h
= msymbol_hash (name
) % HASH_SIZE
;
3767 struct cache_entry
*e
=
3768 (struct cache_entry
*) obstack_alloc (&cache_space
, sizeof (*e
));
3771 e
->name
= copy
= obstack_alloc (&cache_space
, strlen (name
) + 1);
3772 strcpy (copy
, name
);
3774 e
->namespace = namespace;
3781 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3782 struct symbol
**sym
, struct block
**block
,
3783 struct symtab
**symtab
)
3789 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3790 struct block
*block
, struct symtab
*symtab
)
3793 #endif /* GNAT_GDB */
3797 /* Return the result of a standard (literal, C-like) lookup of NAME in
3798 given DOMAIN, visible from lexical block BLOCK. */
3800 static struct symbol
*
3801 standard_lookup (const char *name
, const struct block
*block
,
3805 struct symtab
*symtab
;
3807 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3810 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3811 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3816 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3817 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3818 since they contend in overloading in the same way. */
3820 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3824 for (i
= 0; i
< n
; i
+= 1)
3825 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3826 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3827 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3833 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3834 struct types. Otherwise, they may not. */
3837 equiv_types (struct type
*type0
, struct type
*type1
)
3841 if (type0
== NULL
|| type1
== NULL
3842 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3844 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3845 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3846 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3847 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3853 /* True iff SYM0 represents the same entity as SYM1, or one that is
3854 no more defined than that of SYM1. */
3857 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3861 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3862 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3865 switch (SYMBOL_CLASS (sym0
))
3871 struct type
*type0
= SYMBOL_TYPE (sym0
);
3872 struct type
*type1
= SYMBOL_TYPE (sym1
);
3873 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3874 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3875 int len0
= strlen (name0
);
3877 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3878 && (equiv_types (type0
, type1
)
3879 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3880 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3883 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3884 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3890 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3891 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3894 add_defn_to_vec (struct obstack
*obstackp
,
3896 struct block
*block
, struct symtab
*symtab
)
3900 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3902 if (SYMBOL_TYPE (sym
) != NULL
)
3903 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3904 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3906 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3908 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3910 prevDefns
[i
].sym
= sym
;
3911 prevDefns
[i
].block
= block
;
3912 prevDefns
[i
].symtab
= symtab
;
3918 struct ada_symbol_info info
;
3922 info
.symtab
= symtab
;
3923 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3927 /* Number of ada_symbol_info structures currently collected in
3928 current vector in *OBSTACKP. */
3931 num_defns_collected (struct obstack
*obstackp
)
3933 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3936 /* Vector of ada_symbol_info structures currently collected in current
3937 vector in *OBSTACKP. If FINISH, close off the vector and return
3938 its final address. */
3940 static struct ada_symbol_info
*
3941 defns_collected (struct obstack
*obstackp
, int finish
)
3944 return obstack_finish (obstackp
);
3946 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3949 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3950 Check the global symbols if GLOBAL, the static symbols if not.
3951 Do wild-card match if WILD. */
3953 static struct partial_symbol
*
3954 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3955 int global
, domain_enum
namespace, int wild
)
3957 struct partial_symbol
**start
;
3958 int name_len
= strlen (name
);
3959 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3968 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3969 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3973 for (i
= 0; i
< length
; i
+= 1)
3975 struct partial_symbol
*psym
= start
[i
];
3977 if (SYMBOL_DOMAIN (psym
) == namespace
3978 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3992 int M
= (U
+ i
) >> 1;
3993 struct partial_symbol
*psym
= start
[M
];
3994 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3996 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3998 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
4009 struct partial_symbol
*psym
= start
[i
];
4011 if (SYMBOL_DOMAIN (psym
) == namespace)
4013 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
4021 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4035 int M
= (U
+ i
) >> 1;
4036 struct partial_symbol
*psym
= start
[M
];
4037 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
4039 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
4041 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4052 struct partial_symbol
*psym
= start
[i
];
4054 if (SYMBOL_DOMAIN (psym
) == namespace)
4058 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4061 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4063 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4073 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4083 /* Find a symbol table containing symbol SYM or NULL if none. */
4085 static struct symtab
*
4086 symtab_for_sym (struct symbol
*sym
)
4089 struct objfile
*objfile
;
4091 struct symbol
*tmp_sym
;
4092 struct dict_iterator iter
;
4095 ALL_SYMTABS (objfile
, s
)
4097 switch (SYMBOL_CLASS (sym
))
4105 case LOC_CONST_BYTES
:
4106 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4107 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4109 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4110 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4116 switch (SYMBOL_CLASS (sym
))
4122 case LOC_REGPARM_ADDR
:
4127 case LOC_BASEREG_ARG
:
4129 case LOC_COMPUTED_ARG
:
4130 for (j
= FIRST_LOCAL_BLOCK
;
4131 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4133 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4134 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4145 /* Return a minimal symbol matching NAME according to Ada decoding
4146 rules. Returns NULL if there is no such minimal symbol. Names
4147 prefixed with "standard__" are handled specially: "standard__" is
4148 first stripped off, and only static and global symbols are searched. */
4150 struct minimal_symbol
*
4151 ada_lookup_simple_minsym (const char *name
)
4153 struct objfile
*objfile
;
4154 struct minimal_symbol
*msymbol
;
4157 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4159 name
+= sizeof ("standard__") - 1;
4163 wild_match
= (strstr (name
, "__") == NULL
);
4165 ALL_MSYMBOLS (objfile
, msymbol
)
4167 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4168 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4175 /* Return up minimal symbol for NAME, folded and encoded according to
4176 Ada conventions, or NULL if none. The last two arguments are ignored. */
4178 static struct minimal_symbol
*
4179 ada_lookup_minimal_symbol (const char *name
, const char *sfile
,
4180 struct objfile
*objf
)
4182 return ada_lookup_simple_minsym (ada_encode (name
));
4185 /* For all subprograms that statically enclose the subprogram of the
4186 selected frame, add symbols matching identifier NAME in DOMAIN
4187 and their blocks to the list of data in OBSTACKP, as for
4188 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4192 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4193 const char *name
, domain_enum
namespace,
4196 #ifdef HAVE_ADD_SYMBOLS_FROM_ENCLOSING_PROCS
4197 /* Use a heuristic to find the frames of enclosing subprograms: treat the
4198 pointer-sized value at location 0 from the local-variable base of a
4199 frame as a static link, and then search up the call stack for a
4200 frame with that same local-variable base. */
4201 static struct symbol static_link_sym
;
4202 static struct symbol
*static_link
;
4203 struct value
*target_link_val
;
4205 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4206 struct frame_info
*frame
;
4208 if (!target_has_stack
)
4211 if (static_link
== NULL
)
4213 /* Initialize the local variable symbol that stands for the
4214 static link (when there is one). */
4215 static_link
= &static_link_sym
;
4216 SYMBOL_LINKAGE_NAME (static_link
) = "";
4217 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
4218 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
4219 SYMBOL_DOMAIN (static_link
) = VAR_DOMAIN
;
4220 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
4221 SYMBOL_VALUE (static_link
) =
4222 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
4225 frame
= get_selected_frame ();
4226 if (frame
== NULL
|| inside_main_func (get_frame_address_in_block (frame
)))
4229 target_link_val
= read_var_value (static_link
, frame
);
4230 while (target_link_val
!= NULL
4231 && num_defns_collected (obstackp
) == 0
4232 && frame_relative_level (frame
) <= MAX_ENCLOSING_FRAME_LEVELS
)
4234 CORE_ADDR target_link
= value_as_address (target_link_val
);
4236 frame
= get_prev_frame (frame
);
4240 if (get_frame_locals_address (frame
) == target_link
)
4242 struct block
*block
;
4246 block
= get_frame_block (frame
, 0);
4247 while (block
!= NULL
&& block_function (block
) != NULL
4248 && num_defns_collected (obstackp
) == 0)
4252 ada_add_block_symbols (obstackp
, block
, name
, namespace,
4253 NULL
, NULL
, wild_match
);
4255 block
= BLOCK_SUPERBLOCK (block
);
4260 do_cleanups (old_chain
);
4264 /* FIXME: The next two routines belong in symtab.c */
4267 restore_language (void *lang
)
4269 set_language ((enum language
) lang
);
4272 /* As for lookup_symbol, but performed as if the current language
4276 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4277 domain_enum domain
, enum language lang
,
4278 int *is_a_field_of_this
, struct symtab
**symtab
)
4280 struct cleanup
*old_chain
4281 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4282 struct symbol
*result
;
4283 set_language (lang
);
4284 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4285 do_cleanups (old_chain
);
4289 /* True if TYPE is definitely an artificial type supplied to a symbol
4290 for which no debugging information was given in the symbol file. */
4293 is_nondebugging_type (struct type
*type
)
4295 char *name
= ada_type_name (type
);
4296 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4299 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4300 duplicate other symbols in the list (The only case I know of where
4301 this happens is when object files containing stabs-in-ecoff are
4302 linked with files containing ordinary ecoff debugging symbols (or no
4303 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4304 Returns the number of items in the modified list. */
4307 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4314 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4315 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4316 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4318 for (j
= 0; j
< nsyms
; j
+= 1)
4321 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4322 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4323 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4324 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4325 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4326 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4329 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4330 syms
[k
- 1] = syms
[k
];
4343 /* Given a type that corresponds to a renaming entity, use the type name
4344 to extract the scope (package name or function name, fully qualified,
4345 and following the GNAT encoding convention) where this renaming has been
4346 defined. The string returned needs to be deallocated after use. */
4349 xget_renaming_scope (struct type
*renaming_type
)
4351 /* The renaming types adhere to the following convention:
4352 <scope>__<rename>___<XR extension>.
4353 So, to extract the scope, we search for the "___XR" extension,
4354 and then backtrack until we find the first "__". */
4356 const char *name
= type_name_no_tag (renaming_type
);
4357 char *suffix
= strstr (name
, "___XR");
4362 /* Now, backtrack a bit until we find the first "__". Start looking
4363 at suffix - 3, as the <rename> part is at least one character long. */
4365 for (last
= suffix
- 3; last
> name
; last
--)
4366 if (last
[0] == '_' && last
[1] == '_')
4369 /* Make a copy of scope and return it. */
4371 scope_len
= last
- name
;
4372 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4374 strncpy (scope
, name
, scope_len
);
4375 scope
[scope_len
] = '\0';
4380 /* Return nonzero if NAME corresponds to a package name. */
4383 is_package_name (const char *name
)
4385 /* Here, We take advantage of the fact that no symbols are generated
4386 for packages, while symbols are generated for each function.
4387 So the condition for NAME represent a package becomes equivalent
4388 to NAME not existing in our list of symbols. There is only one
4389 small complication with library-level functions (see below). */
4393 /* If it is a function that has not been defined at library level,
4394 then we should be able to look it up in the symbols. */
4395 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4398 /* Library-level function names start with "_ada_". See if function
4399 "_ada_" followed by NAME can be found. */
4401 /* Do a quick check that NAME does not contain "__", since library-level
4402 functions names can not contain "__" in them. */
4403 if (strstr (name
, "__") != NULL
)
4406 fun_name
= xstrprintf ("_ada_%s", name
);
4408 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4411 /* Return nonzero if SYM corresponds to a renaming entity that is
4412 visible from FUNCTION_NAME. */
4415 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4417 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4419 make_cleanup (xfree
, scope
);
4421 /* If the rename has been defined in a package, then it is visible. */
4422 if (is_package_name (scope
))
4425 /* Check that the rename is in the current function scope by checking
4426 that its name starts with SCOPE. */
4428 /* If the function name starts with "_ada_", it means that it is
4429 a library-level function. Strip this prefix before doing the
4430 comparison, as the encoding for the renaming does not contain
4432 if (strncmp (function_name
, "_ada_", 5) == 0)
4435 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4438 /* Iterates over the SYMS list and remove any entry that corresponds to
4439 a renaming entity that is not visible from the function associated
4443 GNAT emits a type following a specified encoding for each renaming
4444 entity. Unfortunately, STABS currently does not support the definition
4445 of types that are local to a given lexical block, so all renamings types
4446 are emitted at library level. As a consequence, if an application
4447 contains two renaming entities using the same name, and a user tries to
4448 print the value of one of these entities, the result of the ada symbol
4449 lookup will also contain the wrong renaming type.
4451 This function partially covers for this limitation by attempting to
4452 remove from the SYMS list renaming symbols that should be visible
4453 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4454 method with the current information available. The implementation
4455 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4457 - When the user tries to print a rename in a function while there
4458 is another rename entity defined in a package: Normally, the
4459 rename in the function has precedence over the rename in the
4460 package, so the latter should be removed from the list. This is
4461 currently not the case.
4463 - This function will incorrectly remove valid renames if
4464 the CURRENT_BLOCK corresponds to a function which symbol name
4465 has been changed by an "Export" pragma. As a consequence,
4466 the user will be unable to print such rename entities. */
4469 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4470 int nsyms
, struct block
*current_block
)
4472 struct symbol
*current_function
;
4473 char *current_function_name
;
4476 /* Extract the function name associated to CURRENT_BLOCK.
4477 Abort if unable to do so. */
4479 if (current_block
== NULL
)
4482 current_function
= block_function (current_block
);
4483 if (current_function
== NULL
)
4486 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4487 if (current_function_name
== NULL
)
4490 /* Check each of the symbols, and remove it from the list if it is
4491 a type corresponding to a renaming that is out of the scope of
4492 the current block. */
4497 if (ada_is_object_renaming (syms
[i
].sym
)
4498 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4501 for (j
= i
+ 1; j
< nsyms
; j
++)
4502 syms
[j
- 1] = syms
[j
];
4512 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4513 scope and in global scopes, returning the number of matches. Sets
4514 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4515 indicating the symbols found and the blocks and symbol tables (if
4516 any) in which they were found. This vector are transient---good only to
4517 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4518 symbol match within the nest of blocks whose innermost member is BLOCK0,
4519 is the one match returned (no other matches in that or
4520 enclosing blocks is returned). If there are any matches in or
4521 surrounding BLOCK0, then these alone are returned. Otherwise, the
4522 search extends to global and file-scope (static) symbol tables.
4523 Names prefixed with "standard__" are handled specially: "standard__"
4524 is first stripped off, and only static and global symbols are searched. */
4527 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4528 domain_enum
namespace,
4529 struct ada_symbol_info
**results
)
4533 struct partial_symtab
*ps
;
4534 struct blockvector
*bv
;
4535 struct objfile
*objfile
;
4536 struct block
*block
;
4538 struct minimal_symbol
*msymbol
;
4544 obstack_free (&symbol_list_obstack
, NULL
);
4545 obstack_init (&symbol_list_obstack
);
4549 /* Search specified block and its superiors. */
4551 wild_match
= (strstr (name0
, "__") == NULL
);
4553 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4554 needed, but adding const will
4555 have a cascade effect. */
4556 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4560 name
= name0
+ sizeof ("standard__") - 1;
4564 while (block
!= NULL
)
4567 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4568 namespace, NULL
, NULL
, wild_match
);
4570 /* If we found a non-function match, assume that's the one. */
4571 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4572 num_defns_collected (&symbol_list_obstack
)))
4575 block
= BLOCK_SUPERBLOCK (block
);
4578 /* If no luck so far, try to find NAME as a local symbol in some lexically
4579 enclosing subprogram. */
4580 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4581 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4582 name
, namespace, wild_match
);
4584 /* If we found ANY matches among non-global symbols, we're done. */
4586 if (num_defns_collected (&symbol_list_obstack
) > 0)
4590 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4593 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4597 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4598 tables, and psymtab's. */
4600 ALL_SYMTABS (objfile
, s
)
4605 bv
= BLOCKVECTOR (s
);
4606 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4607 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4608 objfile
, s
, wild_match
);
4611 if (namespace == VAR_DOMAIN
)
4613 ALL_MSYMBOLS (objfile
, msymbol
)
4615 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4617 switch (MSYMBOL_TYPE (msymbol
))
4619 case mst_solib_trampoline
:
4622 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4625 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4627 bv
= BLOCKVECTOR (s
);
4628 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4629 ada_add_block_symbols (&symbol_list_obstack
, block
,
4630 SYMBOL_LINKAGE_NAME (msymbol
),
4631 namespace, objfile
, s
, wild_match
);
4633 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4635 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4636 ada_add_block_symbols (&symbol_list_obstack
, block
,
4637 SYMBOL_LINKAGE_NAME (msymbol
),
4638 namespace, objfile
, s
,
4647 ALL_PSYMTABS (objfile
, ps
)
4651 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4653 s
= PSYMTAB_TO_SYMTAB (ps
);
4656 bv
= BLOCKVECTOR (s
);
4657 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4658 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4659 namespace, objfile
, s
, wild_match
);
4663 /* Now add symbols from all per-file blocks if we've gotten no hits
4664 (Not strictly correct, but perhaps better than an error).
4665 Do the symtabs first, then check the psymtabs. */
4667 if (num_defns_collected (&symbol_list_obstack
) == 0)
4670 ALL_SYMTABS (objfile
, s
)
4675 bv
= BLOCKVECTOR (s
);
4676 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4677 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4678 objfile
, s
, wild_match
);
4681 ALL_PSYMTABS (objfile
, ps
)
4685 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4687 s
= PSYMTAB_TO_SYMTAB (ps
);
4688 bv
= BLOCKVECTOR (s
);
4691 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4692 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4693 namespace, objfile
, s
, wild_match
);
4699 ndefns
= num_defns_collected (&symbol_list_obstack
);
4700 *results
= defns_collected (&symbol_list_obstack
, 1);
4702 ndefns
= remove_extra_symbols (*results
, ndefns
);
4705 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4707 if (ndefns
== 1 && cacheIfUnique
)
4708 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4709 (*results
)[0].symtab
);
4711 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4712 (struct block
*) block0
);
4717 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4718 scope and in global scopes, or NULL if none. NAME is folded and
4719 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4720 but is disambiguated by user query if needed. *IS_A_FIELD_OF_THIS is
4721 set to 0 and *SYMTAB is set to the symbol table in which the symbol
4722 was found (in both cases, these assignments occur only if the
4723 pointers are non-null). */
4727 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4728 domain_enum
namespace, int *is_a_field_of_this
,
4729 struct symtab
**symtab
)
4731 struct ada_symbol_info
*candidates
;
4734 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4735 block0
, namespace, &candidates
);
4737 if (n_candidates
== 0)
4739 else if (n_candidates
!= 1)
4740 user_select_syms (candidates
, n_candidates
, 1);
4742 if (is_a_field_of_this
!= NULL
)
4743 *is_a_field_of_this
= 0;
4747 *symtab
= candidates
[0].symtab
;
4748 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4750 struct objfile
*objfile
;
4753 struct blockvector
*bv
;
4755 /* Search the list of symtabs for one which contains the
4756 address of the start of this block. */
4757 ALL_SYMTABS (objfile
, s
)
4759 bv
= BLOCKVECTOR (s
);
4760 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4761 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4762 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4765 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4767 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4771 return candidates
[0].sym
;
4774 static struct symbol
*
4775 ada_lookup_symbol_nonlocal (const char *name
,
4776 const char *linkage_name
,
4777 const struct block
*block
,
4778 const domain_enum domain
, struct symtab
**symtab
)
4780 if (linkage_name
== NULL
)
4781 linkage_name
= name
;
4782 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4787 /* True iff STR is a possible encoded suffix of a normal Ada name
4788 that is to be ignored for matching purposes. Suffixes of parallel
4789 names (e.g., XVE) are not included here. Currently, the possible suffixes
4790 are given by either of the regular expression:
4792 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4794 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4795 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(LJM|X([FDBUP].*|R[^T]?)))?$
4799 is_name_suffix (const char *str
)
4802 const char *matching
;
4803 const int len
= strlen (str
);
4805 /* (__[0-9]+)?\.[0-9]+ */
4807 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4810 while (isdigit (matching
[0]))
4812 if (matching
[0] == '\0')
4816 if (matching
[0] == '.')
4819 while (isdigit (matching
[0]))
4821 if (matching
[0] == '\0')
4826 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4829 while (isdigit (matching
[0]))
4831 if (matching
[0] == '\0')
4835 /* ??? We should not modify STR directly, as we are doing below. This
4836 is fine in this case, but may become problematic later if we find
4837 that this alternative did not work, and want to try matching
4838 another one from the begining of STR. Since we modified it, we
4839 won't be able to find the begining of the string anymore! */
4843 while (str
[0] != '_' && str
[0] != '\0')
4845 if (str
[0] != 'n' && str
[0] != 'b')
4850 if (str
[0] == '\000')
4854 if (str
[1] != '_' || str
[2] == '\000')
4858 if (strcmp (str
+ 3, "LJM") == 0)
4862 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4863 || str
[4] == 'U' || str
[4] == 'P')
4865 if (str
[4] == 'R' && str
[5] != 'T')
4869 if (!isdigit (str
[2]))
4871 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4872 if (!isdigit (str
[k
]) && str
[k
] != '_')
4876 if (str
[0] == '$' && isdigit (str
[1]))
4878 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4879 if (!isdigit (str
[k
]) && str
[k
] != '_')
4886 /* Return nonzero if the given string starts with a dot ('.')
4887 followed by zero or more digits.
4889 Note: brobecker/2003-11-10: A forward declaration has not been
4890 added at the begining of this file yet, because this function
4891 is only used to work around a problem found during wild matching
4892 when trying to match minimal symbol names against symbol names
4893 obtained from dwarf-2 data. This function is therefore currently
4894 only used in wild_match() and is likely to be deleted when the
4895 problem in dwarf-2 is fixed. */
4898 is_dot_digits_suffix (const char *str
)
4904 while (isdigit (str
[0]))
4906 return (str
[0] == '\0');
4909 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4910 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4911 informational suffixes of NAME (i.e., for which is_name_suffix is
4915 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4921 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4922 stored in the symbol table for nested function names is sometimes
4923 different from the name of the associated entity stored in
4924 the dwarf-2 data: This is the case for nested subprograms, where
4925 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4926 while the symbol name from the dwarf-2 data does not.
4928 Although the DWARF-2 standard documents that entity names stored
4929 in the dwarf-2 data should be identical to the name as seen in
4930 the source code, GNAT takes a different approach as we already use
4931 a special encoding mechanism to convey the information so that
4932 a C debugger can still use the information generated to debug
4933 Ada programs. A corollary is that the symbol names in the dwarf-2
4934 data should match the names found in the symbol table. I therefore
4935 consider this issue as a compiler defect.
4937 Until the compiler is properly fixed, we work-around the problem
4938 by ignoring such suffixes during the match. We do so by making
4939 a copy of PATN0 and NAME0, and then by stripping such a suffix
4940 if present. We then perform the match on the resulting strings. */
4943 name_len
= strlen (name0
);
4945 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4946 strcpy (name
, name0
);
4947 dot
= strrchr (name
, '.');
4948 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4951 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4952 strncpy (patn
, patn0
, patn_len
);
4953 patn
[patn_len
] = '\0';
4954 dot
= strrchr (patn
, '.');
4955 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4958 patn_len
= dot
- patn
;
4962 /* Now perform the wild match. */
4964 name_len
= strlen (name
);
4965 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4966 && strncmp (patn
, name
+ 5, patn_len
) == 0
4967 && is_name_suffix (name
+ patn_len
+ 5))
4970 while (name_len
>= patn_len
)
4972 if (strncmp (patn
, name
, patn_len
) == 0
4973 && is_name_suffix (name
+ patn_len
))
4981 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4986 if (!islower (name
[2]))
4993 if (!islower (name
[1]))
5004 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
5005 vector *defn_symbols, updating the list of symbols in OBSTACKP
5006 (if necessary). If WILD, treat as NAME with a wildcard prefix.
5007 OBJFILE is the section containing BLOCK.
5008 SYMTAB is recorded with each symbol added. */
5011 ada_add_block_symbols (struct obstack
*obstackp
,
5012 struct block
*block
, const char *name
,
5013 domain_enum domain
, struct objfile
*objfile
,
5014 struct symtab
*symtab
, int wild
)
5016 struct dict_iterator iter
;
5017 int name_len
= strlen (name
);
5018 /* A matching argument symbol, if any. */
5019 struct symbol
*arg_sym
;
5020 /* Set true when we find a matching non-argument symbol. */
5029 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5031 if (SYMBOL_DOMAIN (sym
) == domain
5032 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5034 switch (SYMBOL_CLASS (sym
))
5040 case LOC_REGPARM_ADDR
:
5041 case LOC_BASEREG_ARG
:
5042 case LOC_COMPUTED_ARG
:
5045 case LOC_UNRESOLVED
:
5049 add_defn_to_vec (obstackp
,
5050 fixup_symbol_section (sym
, objfile
),
5059 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5061 if (SYMBOL_DOMAIN (sym
) == domain
)
5063 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5065 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5067 switch (SYMBOL_CLASS (sym
))
5073 case LOC_REGPARM_ADDR
:
5074 case LOC_BASEREG_ARG
:
5075 case LOC_COMPUTED_ARG
:
5078 case LOC_UNRESOLVED
:
5082 add_defn_to_vec (obstackp
,
5083 fixup_symbol_section (sym
, objfile
),
5092 if (!found_sym
&& arg_sym
!= NULL
)
5094 add_defn_to_vec (obstackp
,
5095 fixup_symbol_section (arg_sym
, objfile
),
5104 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5106 if (SYMBOL_DOMAIN (sym
) == domain
)
5110 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5113 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5115 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5120 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5122 switch (SYMBOL_CLASS (sym
))
5128 case LOC_REGPARM_ADDR
:
5129 case LOC_BASEREG_ARG
:
5130 case LOC_COMPUTED_ARG
:
5133 case LOC_UNRESOLVED
:
5137 add_defn_to_vec (obstackp
,
5138 fixup_symbol_section (sym
, objfile
),
5147 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5148 They aren't parameters, right? */
5149 if (!found_sym
&& arg_sym
!= NULL
)
5151 add_defn_to_vec (obstackp
,
5152 fixup_symbol_section (arg_sym
, objfile
),
5160 /* Symbol Completion */
5162 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5163 name in a form that's appropriate for the completion. The result
5164 does not need to be deallocated, but is only good until the next call.
5166 TEXT_LEN is equal to the length of TEXT.
5167 Perform a wild match if WILD_MATCH is set.
5168 ENCODED should be set if TEXT represents the start of a symbol name
5169 in its encoded form. */
5172 symbol_completion_match (const char *sym_name
,
5173 const char *text
, int text_len
,
5174 int wild_match
, int encoded
)
5177 const int verbatim_match
= (text
[0] == '<');
5182 /* Strip the leading angle bracket. */
5187 /* First, test against the fully qualified name of the symbol. */
5189 if (strncmp (sym_name
, text
, text_len
) == 0)
5192 if (match
&& !encoded
)
5194 /* One needed check before declaring a positive match is to verify
5195 that iff we are doing a verbatim match, the decoded version
5196 of the symbol name starts with '<'. Otherwise, this symbol name
5197 is not a suitable completion. */
5198 const char *sym_name_copy
= sym_name
;
5199 int has_angle_bracket
;
5201 sym_name
= ada_decode (sym_name
);
5202 has_angle_bracket
= (sym_name
[0] == '<');
5203 match
= (has_angle_bracket
== verbatim_match
);
5204 sym_name
= sym_name_copy
;
5207 if (match
&& !verbatim_match
)
5209 /* When doing non-verbatim match, another check that needs to
5210 be done is to verify that the potentially matching symbol name
5211 does not include capital letters, because the ada-mode would
5212 not be able to understand these symbol names without the
5213 angle bracket notation. */
5216 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5221 /* Second: Try wild matching... */
5223 if (!match
&& wild_match
)
5225 /* Since we are doing wild matching, this means that TEXT
5226 may represent an unqualified symbol name. We therefore must
5227 also compare TEXT against the unqualified name of the symbol. */
5228 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5230 if (strncmp (sym_name
, text
, text_len
) == 0)
5234 /* Finally: If we found a mach, prepare the result to return. */
5240 sym_name
= add_angle_brackets (sym_name
);
5243 sym_name
= ada_decode (sym_name
);
5248 /* A companion function to ada_make_symbol_completion_list().
5249 Check if SYM_NAME represents a symbol which name would be suitable
5250 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5251 it is appended at the end of the given string vector SV.
5253 ORIG_TEXT is the string original string from the user command
5254 that needs to be completed. WORD is the entire command on which
5255 completion should be performed. These two parameters are used to
5256 determine which part of the symbol name should be added to the
5258 if WILD_MATCH is set, then wild matching is performed.
5259 ENCODED should be set if TEXT represents a symbol name in its
5260 encoded formed (in which case the completion should also be
5264 symbol_completion_add (struct string_vector
*sv
,
5265 const char *sym_name
,
5266 const char *text
, int text_len
,
5267 const char *orig_text
, const char *word
,
5268 int wild_match
, int encoded
)
5270 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5271 wild_match
, encoded
);
5277 /* We found a match, so add the appropriate completion to the given
5280 if (word
== orig_text
)
5282 completion
= xmalloc (strlen (match
) + 5);
5283 strcpy (completion
, match
);
5285 else if (word
> orig_text
)
5287 /* Return some portion of sym_name. */
5288 completion
= xmalloc (strlen (match
) + 5);
5289 strcpy (completion
, match
+ (word
- orig_text
));
5293 /* Return some of ORIG_TEXT plus sym_name. */
5294 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5295 strncpy (completion
, word
, orig_text
- word
);
5296 completion
[orig_text
- word
] = '\0';
5297 strcat (completion
, match
);
5300 string_vector_append (sv
, completion
);
5303 /* Return a list of possible symbol names completing TEXT0. The list
5304 is NULL terminated. WORD is the entire command on which completion
5308 ada_make_symbol_completion_list (const char *text0
, const char *word
)
5310 /* Note: This function is almost a copy of make_symbol_completion_list(),
5311 except it has been adapted for Ada. It is somewhat of a shame to
5312 duplicate so much code, but we don't really have the infrastructure
5313 yet to develop a language-aware version of he symbol completer... */
5318 struct string_vector result
= xnew_string_vector (128);
5321 struct partial_symtab
*ps
;
5322 struct minimal_symbol
*msymbol
;
5323 struct objfile
*objfile
;
5324 struct block
*b
, *surrounding_static_block
= 0;
5326 struct dict_iterator iter
;
5328 if (text0
[0] == '<')
5330 text
= xstrdup (text0
);
5331 make_cleanup (xfree
, text
);
5332 text_len
= strlen (text
);
5338 text
= xstrdup (ada_encode (text0
));
5339 make_cleanup (xfree
, text
);
5340 text_len
= strlen (text
);
5341 for (i
= 0; i
< text_len
; i
++)
5342 text
[i
] = tolower (text
[i
]);
5344 /* FIXME: brobecker/2003-09-17: When we get rid of ADA_RETAIN_DOTS,
5345 we can restrict the wild_match check to searching "__" only. */
5346 wild_match
= (strstr (text0
, "__") == NULL
5347 && strchr (text0
, '.') == NULL
);
5348 encoded
= (strstr (text0
, "__") != NULL
);
5351 /* First, look at the partial symtab symbols. */
5352 ALL_PSYMTABS (objfile
, ps
)
5354 struct partial_symbol
**psym
;
5356 /* If the psymtab's been read in we'll get it when we search
5357 through the blockvector. */
5361 for (psym
= objfile
->global_psymbols
.list
+ ps
->globals_offset
;
5362 psym
< (objfile
->global_psymbols
.list
+ ps
->globals_offset
5363 + ps
->n_global_syms
); psym
++)
5366 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (*psym
),
5367 text
, text_len
, text0
, word
,
5368 wild_match
, encoded
);
5371 for (psym
= objfile
->static_psymbols
.list
+ ps
->statics_offset
;
5372 psym
< (objfile
->static_psymbols
.list
+ ps
->statics_offset
5373 + ps
->n_static_syms
); psym
++)
5376 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (*psym
),
5377 text
, text_len
, text0
, word
,
5378 wild_match
, encoded
);
5382 /* At this point scan through the misc symbol vectors and add each
5383 symbol you find to the list. Eventually we want to ignore
5384 anything that isn't a text symbol (everything else will be
5385 handled by the psymtab code above). */
5387 ALL_MSYMBOLS (objfile
, msymbol
)
5390 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (msymbol
),
5391 text
, text_len
, text0
, word
, wild_match
, encoded
);
5394 /* Search upwards from currently selected frame (so that we can
5395 complete on local vars. */
5397 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5399 if (!BLOCK_SUPERBLOCK (b
))
5400 surrounding_static_block
= b
; /* For elmin of dups */
5402 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5404 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5405 text
, text_len
, text0
, word
,
5406 wild_match
, encoded
);
5410 /* Go through the symtabs and check the externs and statics for
5411 symbols which match. */
5413 ALL_SYMTABS (objfile
, s
)
5416 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5417 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5419 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5420 text
, text_len
, text0
, word
,
5421 wild_match
, encoded
);
5425 ALL_SYMTABS (objfile
, s
)
5428 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5429 /* Don't do this block twice. */
5430 if (b
== surrounding_static_block
)
5432 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5434 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5435 text
, text_len
, text0
, word
,
5436 wild_match
, encoded
);
5440 /* Append the closing NULL entry. */
5441 string_vector_append (&result
, NULL
);
5443 return (result
.array
);
5446 #endif /* GNAT_GDB */
5449 /* Breakpoint-related */
5451 /* Assuming that LINE is pointing at the beginning of an argument to
5452 'break', return a pointer to the delimiter for the initial segment
5453 of that name. This is the first ':', ' ', or end of LINE. */
5456 ada_start_decode_line_1 (char *line
)
5458 /* NOTE: strpbrk would be more elegant, but I am reluctant to be
5459 the first to use such a library function in GDB code. */
5461 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
5466 /* *SPEC points to a function and line number spec (as in a break
5467 command), following any initial file name specification.
5469 Return all symbol table/line specfications (sals) consistent with the
5470 information in *SPEC and FILE_TABLE in the following sense:
5471 + FILE_TABLE is null, or the sal refers to a line in the file
5472 named by FILE_TABLE.
5473 + If *SPEC points to an argument with a trailing ':LINENUM',
5474 then the sal refers to that line (or one following it as closely as
5476 + If *SPEC does not start with '*', the sal is in a function with
5479 Returns with 0 elements if no matching non-minimal symbols found.
5481 If *SPEC begins with a function name of the form <NAME>, then NAME
5482 is taken as a literal name; otherwise the function name is subject
5483 to the usual encoding.
5485 *SPEC is updated to point after the function/line number specification.
5487 FUNFIRSTLINE is non-zero if we desire the first line of real code
5490 If CANONICAL is non-NULL, and if any of the sals require a
5491 'canonical line spec', then *CANONICAL is set to point to an array
5492 of strings, corresponding to and equal in length to the returned
5493 list of sals, such that (*CANONICAL)[i] is non-null and contains a
5494 canonical line spec for the ith returned sal, if needed. If no
5495 canonical line specs are required and CANONICAL is non-null,
5496 *CANONICAL is set to NULL.
5498 A 'canonical line spec' is simply a name (in the format of the
5499 breakpoint command) that uniquely identifies a breakpoint position,
5500 with no further contextual information or user selection. It is
5501 needed whenever the file name, function name, and line number
5502 information supplied is insufficient for this unique
5503 identification. Currently overloaded functions, the name '*',
5504 or static functions without a filename yield a canonical line spec.
5505 The array and the line spec strings are allocated on the heap; it
5506 is the caller's responsibility to free them. */
5508 struct symtabs_and_lines
5509 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
5510 int funfirstline
, char ***canonical
)
5512 struct ada_symbol_info
*symbols
;
5513 const struct block
*block
;
5514 int n_matches
, i
, line_num
;
5515 struct symtabs_and_lines selected
;
5516 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
5522 char *unquoted_name
;
5524 if (file_table
== NULL
)
5525 block
= block_static_block (get_selected_block (0));
5527 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
5529 if (canonical
!= NULL
)
5530 *canonical
= (char **) NULL
;
5532 is_quoted
= (**spec
&& strchr (get_gdb_completer_quote_characters (),
5541 *spec
= skip_quoted (*spec
);
5542 while (**spec
!= '\000'
5543 && !strchr (ada_completer_word_break_characters
, **spec
))
5549 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
5551 line_num
= strtol (*spec
+ 1, spec
, 10);
5552 while (**spec
== ' ' || **spec
== '\t')
5559 error ("Wild-card function with no line number or file name.");
5561 return ada_sals_for_line (file_table
->filename
, line_num
,
5562 funfirstline
, canonical
, 0);
5565 if (name
[0] == '\'')
5573 unquoted_name
= (char *) alloca (len
- 1);
5574 memcpy (unquoted_name
, name
+ 1, len
- 2);
5575 unquoted_name
[len
- 2] = '\000';
5580 unquoted_name
= (char *) alloca (len
+ 1);
5581 memcpy (unquoted_name
, name
, len
);
5582 unquoted_name
[len
] = '\000';
5583 lower_name
= (char *) alloca (len
+ 1);
5584 for (i
= 0; i
< len
; i
+= 1)
5585 lower_name
[i
] = tolower (name
[i
]);
5586 lower_name
[len
] = '\000';
5590 if (lower_name
!= NULL
)
5591 n_matches
= ada_lookup_symbol_list (ada_encode (lower_name
), block
,
5592 VAR_DOMAIN
, &symbols
);
5594 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
5595 VAR_DOMAIN
, &symbols
);
5596 if (n_matches
== 0 && line_num
>= 0)
5597 error ("No line number information found for %s.", unquoted_name
);
5598 else if (n_matches
== 0)
5600 #ifdef HPPA_COMPILER_BUG
5601 /* FIXME: See comment in symtab.c::decode_line_1 */
5603 volatile struct symtab_and_line val
;
5604 #define volatile /*nothing */
5606 struct symtab_and_line val
;
5608 struct minimal_symbol
*msymbol
;
5613 if (lower_name
!= NULL
)
5614 msymbol
= ada_lookup_simple_minsym (ada_encode (lower_name
));
5615 if (msymbol
== NULL
)
5616 msymbol
= ada_lookup_simple_minsym (unquoted_name
);
5617 if (msymbol
!= NULL
)
5619 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
5620 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
5623 val
.pc
+= DEPRECATED_FUNCTION_START_OFFSET
;
5624 SKIP_PROLOGUE (val
.pc
);
5626 selected
.sals
= (struct symtab_and_line
*)
5627 xmalloc (sizeof (struct symtab_and_line
));
5628 selected
.sals
[0] = val
;
5633 if (!have_full_symbols ()
5634 && !have_partial_symbols () && !have_minimal_symbols ())
5635 error ("No symbol table is loaded. Use the \"file\" command.");
5637 error ("Function \"%s\" not defined.", unquoted_name
);
5638 return selected
; /* for lint */
5643 struct symtabs_and_lines best_sal
=
5644 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
5645 symbols
, n_matches
);
5647 adjust_pc_past_prologue (&best_sal
.sals
[0].pc
);
5652 selected
.nelts
= user_select_syms (symbols
, n_matches
, n_matches
);
5655 selected
.sals
= (struct symtab_and_line
*)
5656 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
5657 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
5658 make_cleanup (xfree
, selected
.sals
);
5661 while (i
< selected
.nelts
)
5663 if (SYMBOL_CLASS (symbols
[i
].sym
) == LOC_BLOCK
)
5665 = find_function_start_sal (symbols
[i
].sym
, funfirstline
);
5666 else if (SYMBOL_LINE (symbols
[i
].sym
) != 0)
5668 selected
.sals
[i
].symtab
=
5670 ? symbols
[i
].symtab
: symtab_for_sym (symbols
[i
].sym
);
5671 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
].sym
);
5673 else if (line_num
>= 0)
5675 /* Ignore this choice */
5676 symbols
[i
] = symbols
[selected
.nelts
- 1];
5677 selected
.nelts
-= 1;
5681 error ("Line number not known for symbol \"%s\"", unquoted_name
);
5685 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
5687 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
5688 for (i
= 0; i
< selected
.nelts
; i
+= 1)
5690 extended_canonical_line_spec (selected
.sals
[i
],
5691 SYMBOL_PRINT_NAME (symbols
[i
].sym
));
5694 discard_cleanups (old_chain
);
5698 /* The (single) sal corresponding to line LINE_NUM in a symbol table
5699 with file name FILENAME that occurs in one of the functions listed
5700 in the symbol fields of SYMBOLS[0 .. NSYMS-1]. */
5702 static struct symtabs_and_lines
5703 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
5704 struct ada_symbol_info
*symbols
, int nsyms
)
5706 struct symtabs_and_lines sals
;
5707 int best_index
, best
;
5708 struct linetable
*best_linetable
;
5709 struct objfile
*objfile
;
5711 struct symtab
*best_symtab
;
5713 read_all_symtabs (filename
);
5716 best_linetable
= NULL
;
5719 ALL_SYMTABS (objfile
, s
)
5721 struct linetable
*l
;
5726 if (strcmp (filename
, s
->filename
) != 0)
5729 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
5739 if (best
== 0 || l
->item
[ind
].line
< best
)
5741 best
= l
->item
[ind
].line
;
5750 error ("Line number not found in designated function.");
5755 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
5757 init_sal (&sals
.sals
[0]);
5759 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
5760 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
5761 sals
.sals
[0].symtab
= best_symtab
;
5766 /* Return the index in LINETABLE of the best match for LINE_NUM whose
5767 pc falls within one of the functions denoted by the symbol fields
5768 of SYMBOLS[0..NSYMS-1]. Set *EXACTP to 1 if the match is exact,
5772 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
5773 struct ada_symbol_info
*symbols
, int nsyms
,
5776 int i
, len
, best_index
, best
;
5778 if (line_num
<= 0 || linetable
== NULL
)
5781 len
= linetable
->nitems
;
5782 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
5785 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5787 for (k
= 0; k
< nsyms
; k
+= 1)
5789 if (symbols
[k
].sym
!= NULL
5790 && SYMBOL_CLASS (symbols
[k
].sym
) == LOC_BLOCK
5791 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
].sym
))
5792 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
].sym
)))
5799 if (item
->line
== line_num
)
5805 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
5816 /* Find the smallest k >= LINE_NUM such that k is a line number in
5817 LINETABLE, and k falls strictly within a named function that begins at
5818 or before LINE_NUM. Return -1 if there is no such k. */
5821 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
5825 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
5827 len
= linetable
->nitems
;
5833 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5835 if (item
->line
>= line_num
&& item
->line
< best
)
5838 CORE_ADDR start
, end
;
5841 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
5843 if (func_name
!= NULL
&& item
->pc
< end
)
5845 if (item
->line
== line_num
)
5849 struct symbol
*sym
=
5850 standard_lookup (func_name
, NULL
, VAR_DOMAIN
);
5851 if (is_plausible_func_for_line (sym
, line_num
))
5857 while (i
< len
&& linetable
->item
[i
].pc
< end
);
5867 return (best
== INT_MAX
) ? -1 : best
;
5871 /* Return the next higher index, k, into LINETABLE such that k > IND,
5872 entry k in LINETABLE has a line number equal to LINE_NUM, k
5873 corresponds to a PC that is in a function different from that
5874 corresponding to IND, and falls strictly within a named function
5875 that begins at a line at or preceding STARTING_LINE.
5876 Return -1 if there is no such k.
5877 IND == -1 corresponds to no function. */
5880 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
5881 int starting_line
, int ind
)
5885 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
5887 len
= linetable
->nitems
;
5891 CORE_ADDR start
, end
;
5893 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
5894 (char **) NULL
, &start
, &end
))
5896 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
5908 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5910 if (item
->line
>= line_num
)
5913 CORE_ADDR start
, end
;
5916 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
5918 if (func_name
!= NULL
&& item
->pc
< end
)
5920 if (item
->line
== line_num
)
5922 struct symbol
*sym
=
5923 standard_lookup (func_name
, NULL
, VAR_DOMAIN
);
5924 if (is_plausible_func_for_line (sym
, starting_line
))
5928 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
5940 /* True iff function symbol SYM starts somewhere at or before line #
5944 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
5946 struct symtab_and_line start_sal
;
5951 start_sal
= find_function_start_sal (sym
, 0);
5953 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
5956 /* Read in all symbol tables corresponding to partial symbol tables
5957 with file name FILENAME. */
5960 read_all_symtabs (const char *filename
)
5962 struct partial_symtab
*ps
;
5963 struct objfile
*objfile
;
5965 ALL_PSYMTABS (objfile
, ps
)
5969 if (strcmp (filename
, ps
->filename
) == 0)
5970 PSYMTAB_TO_SYMTAB (ps
);
5974 /* All sals corresponding to line LINE_NUM in a symbol table from file
5975 FILENAME, as filtered by the user. Filter out any lines that
5976 reside in functions with "suppressed" names (not corresponding to
5977 explicit Ada functions), if there is at least one in a function
5978 with a non-suppressed name. If CANONICAL is not null, set
5979 it to a corresponding array of canonical line specs.
5980 If ONE_LOCATION_ONLY is set and several matches are found for
5981 the given location, then automatically select the first match found
5982 instead of asking the user which instance should be returned. */
5984 struct symtabs_and_lines
5985 ada_sals_for_line (const char *filename
, int line_num
,
5986 int funfirstline
, char ***canonical
, int one_location_only
)
5988 struct symtabs_and_lines result
;
5989 struct objfile
*objfile
;
5991 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
5994 read_all_symtabs (filename
);
5997 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
6000 make_cleanup (free_current_contents
, &result
.sals
);
6002 ALL_SYMTABS (objfile
, s
)
6004 int ind
, target_line_num
;
6008 if (strcmp (s
->filename
, filename
) != 0)
6012 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
6013 if (target_line_num
== -1)
6020 find_next_line_in_linetable (LINETABLE (s
),
6021 target_line_num
, line_num
, ind
);
6026 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
6027 init_sal (&result
.sals
[result
.nelts
]);
6028 result
.sals
[result
.nelts
].line
= line_num
;
6029 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
6030 result
.sals
[result
.nelts
].symtab
= s
;
6033 adjust_pc_past_prologue (&result
.sals
[result
.nelts
].pc
);
6039 if (canonical
!= NULL
|| result
.nelts
> 1)
6042 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
6043 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
6044 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
6046 for (k
= 0; k
< result
.nelts
; k
+= 1)
6048 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
6049 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
6050 if (func_names
[k
] == NULL
)
6051 error ("Could not find function for one or more breakpoints.");
6054 /* Remove suppressed names, unless all are suppressed. */
6055 for (j
= 0; j
< result
.nelts
; j
+= 1)
6056 if (!is_suppressed_name (func_names
[j
]))
6058 /* At least one name is unsuppressed, so remove all
6059 suppressed names. */
6060 for (k
= n
= 0; k
< result
.nelts
; k
+= 1)
6061 if (!is_suppressed_name (func_names
[k
]))
6063 func_names
[n
] = func_names
[k
];
6064 result
.sals
[n
] = result
.sals
[k
];
6071 if (result
.nelts
> 1)
6073 if (one_location_only
)
6075 /* Automatically select the first of all possible choices. */
6081 printf_unfiltered ("[0] cancel\n");
6082 if (result
.nelts
> 1)
6083 printf_unfiltered ("[1] all\n");
6084 for (k
= 0; k
< result
.nelts
; k
+= 1)
6085 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
6086 ada_decode (func_names
[k
]));
6088 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
6089 result
.nelts
> 1, "instance-choice");
6092 for (k
= 0; k
< n
; k
+= 1)
6094 result
.sals
[k
] = result
.sals
[choices
[k
]];
6095 func_names
[k
] = func_names
[choices
[k
]];
6100 if (canonical
!= NULL
&& result
.nelts
== 0)
6102 else if (canonical
!= NULL
)
6104 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
6105 make_cleanup (xfree
, *canonical
);
6106 for (k
= 0; k
< result
.nelts
; k
+= 1)
6109 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
6110 if ((*canonical
)[k
] == NULL
)
6111 error ("Could not locate one or more breakpoints.");
6112 make_cleanup (xfree
, (*canonical
)[k
]);
6117 if (result
.nelts
== 0)
6119 do_cleanups (old_chain
);
6123 discard_cleanups (old_chain
);
6128 /* A canonical line specification of the form FILE:NAME:LINENUM for
6129 symbol table and line data SAL. NULL if insufficient
6130 information. The caller is responsible for releasing any space
6134 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
6138 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
6141 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
6142 + sizeof (sal
.line
) * 3 + 3);
6143 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
6147 /* Return type of Ada breakpoint associated with bp_stat:
6148 0 if not an Ada-specific breakpoint, 1 for break on specific exception,
6149 2 for break on unhandled exception, 3 for assert. */
6152 ada_exception_breakpoint_type (bpstat bs
)
6154 return ((!bs
|| !bs
->breakpoint_at
) ? 0
6155 : bs
->breakpoint_at
->break_on_exception
);
6158 /* True iff FRAME is very likely to be that of a function that is
6159 part of the runtime system. This is all very heuristic, but is
6160 intended to be used as advice as to what frames are uninteresting
6164 is_known_support_routine (struct frame_info
*frame
)
6166 struct frame_info
*next_frame
= get_next_frame (frame
);
6167 /* If frame is not innermost, that normally means that frame->pc
6168 points to *after* the call instruction, and we want to get the line
6169 containing the call, never the next line. But if the next frame is
6170 a signal_handler_caller or a dummy frame, then the next frame was
6171 not entered as the result of a call, and we want to get the line
6172 containing frame->pc. */
6173 const int pc_is_after_call
=
6175 && get_frame_type (next_frame
) != SIGTRAMP_FRAME
6176 && get_frame_type (next_frame
) != DUMMY_FRAME
;
6177 struct symtab_and_line sal
6178 = find_pc_line (get_frame_pc (frame
), pc_is_after_call
);
6184 1. The symtab is null (indicating no debugging symbols)
6185 2. The symtab's filename does not exist.
6186 3. The object file's name is one of the standard libraries.
6187 4. The symtab's file name has the form of an Ada library source file.
6188 5. The function at frame's PC has a GNAT-compiler-generated name. */
6190 if (sal
.symtab
== NULL
)
6193 /* On some systems (e.g. VxWorks), the kernel contains debugging
6194 symbols; in this case, the filename referenced by these symbols
6197 if (stat (sal
.symtab
->filename
, &st
))
6200 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
6202 re_comp (known_runtime_file_name_patterns
[i
]);
6203 if (re_exec (sal
.symtab
->filename
))
6206 if (sal
.symtab
->objfile
!= NULL
)
6208 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
6210 re_comp (known_runtime_file_name_patterns
[i
]);
6211 if (re_exec (sal
.symtab
->objfile
->name
))
6216 /* If the frame PC points after the call instruction, then we need to
6217 decrement it in order to search for the function associated to this
6218 PC. Otherwise, if the associated call was the last instruction of
6219 the function, we might either find the wrong function or even fail
6220 during the function name lookup. */
6221 if (pc_is_after_call
)
6222 func_name
= function_name_from_pc (get_frame_pc (frame
) - 1);
6224 func_name
= function_name_from_pc (get_frame_pc (frame
));
6226 if (func_name
== NULL
)
6229 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
6231 re_comp (known_auxiliary_function_name_patterns
[i
]);
6232 if (re_exec (func_name
))
6239 /* Find the first frame that contains debugging information and that is not
6240 part of the Ada run-time, starting from FI and moving upward. */
6243 ada_find_printable_frame (struct frame_info
*fi
)
6245 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
6247 if (!is_known_support_routine (fi
))
6256 /* Name found for exception associated with last bpstat sent to
6257 ada_adjust_exception_stop. Set to the null string if that bpstat
6258 did not correspond to an Ada exception or no name could be found. */
6260 static char last_exception_name
[256];
6262 /* If BS indicates a stop in an Ada exception, try to go up to a frame
6263 that will be meaningful to the user, and save the name of the last
6264 exception (truncated, if necessary) in last_exception_name. */
6267 ada_adjust_exception_stop (bpstat bs
)
6270 struct frame_info
*fi
;
6272 char *selected_frame_func
;
6275 last_exception_name
[0] = '\0';
6276 fi
= get_selected_frame ();
6277 selected_frame_func
= function_name_from_pc (get_frame_pc (fi
));
6279 switch (ada_exception_breakpoint_type (bs
))
6286 /* Unhandled exceptions. Select the frame corresponding to
6287 ada.exceptions.process_raise_exception. This frame is at
6288 least 2 levels up, so we simply skip the first 2 frames
6289 without checking the name of their associated function. */
6290 for (frame_level
= 0; frame_level
< 2; frame_level
+= 1)
6292 fi
= get_prev_frame (fi
);
6295 const char *func_name
= function_name_from_pc (get_frame_pc (fi
));
6296 if (func_name
!= NULL
6297 && strcmp (func_name
, process_raise_exception_name
) == 0)
6298 break; /* We found the frame we were looking for... */
6299 fi
= get_prev_frame (fi
);
6307 addr
= parse_and_eval_address ("e.full_name");
6310 read_memory (addr
, last_exception_name
, sizeof (last_exception_name
) - 1);
6311 last_exception_name
[sizeof (last_exception_name
) - 1] = '\0';
6312 ada_find_printable_frame (get_selected_frame ());
6315 /* Output Ada exception name (if any) associated with last call to
6316 ada_adjust_exception_stop. */
6319 ada_print_exception_stop (bpstat bs
)
6321 if (last_exception_name
[0] != '\000')
6323 ui_out_text (uiout
, last_exception_name
);
6324 ui_out_text (uiout
, " at ");
6328 /* Parses the CONDITION string associated with a breakpoint exception
6329 to get the name of the exception on which the breakpoint has been
6330 set. The returned string needs to be deallocated after use. */
6333 exception_name_from_cond (const char *condition
)
6335 char *start
, *end
, *exception_name
;
6336 int exception_name_len
;
6338 start
= strrchr (condition
, '&') + 1;
6339 end
= strchr (start
, ')') - 1;
6340 exception_name_len
= end
- start
+ 1;
6343 (char *) xmalloc ((exception_name_len
+ 1) * sizeof (char));
6344 sprintf (exception_name
, "%.*s", exception_name_len
, start
);
6346 return exception_name
;
6349 /* Print Ada-specific exception information about B, other than task
6350 clause. Return non-zero iff B was an Ada exception breakpoint. */
6353 ada_print_exception_breakpoint_nontask (struct breakpoint
*b
)
6355 if (b
->break_on_exception
== 1)
6357 if (b
->cond_string
) /* the breakpoint is on a specific exception. */
6359 char *exception_name
= exception_name_from_cond (b
->cond_string
);
6361 make_cleanup (xfree
, exception_name
);
6363 ui_out_text (uiout
, "on ");
6364 if (ui_out_is_mi_like_p (uiout
))
6365 ui_out_field_string (uiout
, "exception", exception_name
);
6368 ui_out_text (uiout
, "exception ");
6369 ui_out_text (uiout
, exception_name
);
6370 ui_out_text (uiout
, " ");
6374 ui_out_text (uiout
, "on all exceptions");
6376 else if (b
->break_on_exception
== 2)
6377 ui_out_text (uiout
, "on unhandled exception");
6378 else if (b
->break_on_exception
== 3)
6379 ui_out_text (uiout
, "on assert failure");
6385 /* Print task identifier for breakpoint B, if it is an Ada-specific
6386 breakpoint with non-zero tasking information. */
6389 ada_print_exception_breakpoint_task (struct breakpoint
*b
)
6393 ui_out_text (uiout
, " task ");
6394 ui_out_field_int (uiout
, "task", b
->task
);
6399 ada_is_exception_sym (struct symbol
*sym
)
6401 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
6403 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
6404 && SYMBOL_CLASS (sym
) != LOC_BLOCK
6405 && SYMBOL_CLASS (sym
) != LOC_CONST
6406 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
6410 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
6412 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
6413 && SYMBOL_CLASS (sym
) != LOC_BLOCK
6414 && SYMBOL_CLASS (sym
) != LOC_CONST
);
6417 /* Cause the appropriate error if no appropriate runtime symbol is
6418 found to set a breakpoint, using ERR_DESC to describe the
6422 error_breakpoint_runtime_sym_not_found (const char *err_desc
)
6424 /* If we are not debugging an Ada program, we can not put exception
6427 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
6428 error ("Unable to break on %s. Is this an Ada main program?", err_desc
);
6430 /* If the symbol does not exist, then check that the program is
6431 already started, to make sure that shared libraries have been
6432 loaded. If it is not started, this may mean that the symbol is
6433 in a shared library. */
6435 if (ptid_get_pid (inferior_ptid
) == 0)
6436 error ("Unable to break on %s. Try to start the program first.",
6439 /* At this point, we know that we are debugging an Ada program and
6440 that the inferior has been started, but we still are not able to
6441 find the run-time symbols. That can mean that we are in
6442 configurable run time mode, or that a-except as been optimized
6443 out by the linker... In any case, at this point it is not worth
6444 supporting this feature. */
6446 error ("Cannot break on %s in this configuration.", err_desc
);
6449 /* Test if NAME is currently defined, and that either ALLOW_TRAMP or
6450 the symbol is not a shared-library trampoline. Return the result of
6454 is_runtime_sym_defined (const char *name
, int allow_tramp
)
6456 struct minimal_symbol
*msym
;
6458 msym
= lookup_minimal_symbol (name
, NULL
, NULL
);
6459 return (msym
!= NULL
&& msym
->type
!= mst_unknown
6460 && (allow_tramp
|| msym
->type
!= mst_solib_trampoline
));
6463 /* If ARG points to an Ada exception or assert breakpoint, rewrite
6464 into equivalent form. Return resulting argument string. Set
6465 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
6466 break on unhandled, 3 for assert, 0 otherwise. */
6469 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
6473 *break_on_exceptionp
= 0;
6474 if (current_language
->la_language
== language_ada
6475 && strncmp (arg
, "exception", 9) == 0
6476 && (arg
[9] == ' ' || arg
[9] == '\t' || arg
[9] == '\0'))
6478 char *tok
, *end_tok
;
6480 int has_exception_propagation
=
6481 is_runtime_sym_defined (raise_sym_name
, 1);
6483 *break_on_exceptionp
= 1;
6486 while (*tok
== ' ' || *tok
== '\t')
6491 while (*end_tok
!= ' ' && *end_tok
!= '\t' && *end_tok
!= '\000')
6494 toklen
= end_tok
- tok
;
6496 arg
= (char *) xmalloc (sizeof (longest_exception_template
) + toklen
);
6497 make_cleanup (xfree
, arg
);
6500 if (has_exception_propagation
)
6501 sprintf (arg
, "'%s'", raise_sym_name
);
6503 error_breakpoint_runtime_sym_not_found ("exception");
6505 else if (strncmp (tok
, "unhandled", toklen
) == 0)
6507 if (is_runtime_sym_defined (raise_unhandled_sym_name
, 1))
6508 sprintf (arg
, "'%s'", raise_unhandled_sym_name
);
6510 error_breakpoint_runtime_sym_not_found ("exception");
6512 *break_on_exceptionp
= 2;
6516 if (is_runtime_sym_defined (raise_sym_name
, 0))
6517 sprintf (arg
, "'%s' if long_integer(e) = long_integer(&%.*s)",
6518 raise_sym_name
, toklen
, tok
);
6520 error_breakpoint_runtime_sym_not_found ("specific exception");
6523 else if (current_language
->la_language
== language_ada
6524 && strncmp (arg
, "assert", 6) == 0
6525 && (arg
[6] == ' ' || arg
[6] == '\t' || arg
[6] == '\0'))
6527 char *tok
= arg
+ 6;
6529 if (!is_runtime_sym_defined (raise_assert_sym_name
, 1))
6530 error_breakpoint_runtime_sym_not_found ("failed assertion");
6532 *break_on_exceptionp
= 3;
6535 (char *) xmalloc (sizeof (raise_assert_sym_name
) + strlen (tok
) + 2);
6536 make_cleanup (xfree
, arg
);
6537 sprintf (arg
, "'%s'%s", raise_assert_sym_name
, tok
);
6545 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6546 to be invisible to users. */
6549 ada_is_ignored_field (struct type
*type
, int field_num
)
6551 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6555 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6556 return (name
== NULL
6557 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
6561 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6562 pointer or reference type whose ultimate target has a tag field. */
6565 ada_is_tagged_type (struct type
*type
, int refok
)
6567 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
6570 /* True iff TYPE represents the type of X'Tag */
6573 ada_is_tag_type (struct type
*type
)
6575 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6579 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6580 return (name
!= NULL
6581 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6585 /* The type of the tag on VAL. */
6588 ada_tag_type (struct value
*val
)
6590 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 1, 0, NULL
);
6593 /* The value of the tag on VAL. */
6596 ada_value_tag (struct value
*val
)
6598 return ada_value_struct_elt (val
, "_tag", "record");
6601 /* The value of the tag on the object of type TYPE whose contents are
6602 saved at VALADDR, if it is non-null, or is at memory address
6605 static struct value
*
6606 value_tag_from_contents_and_address (struct type
*type
, char *valaddr
,
6609 int tag_byte_offset
, dummy1
, dummy2
;
6610 struct type
*tag_type
;
6611 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6614 char *valaddr1
= (valaddr
== NULL
) ? NULL
: valaddr
+ tag_byte_offset
;
6615 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6617 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6622 static struct type
*
6623 type_from_tag (struct value
*tag
)
6625 const char *type_name
= ada_tag_name (tag
);
6626 if (type_name
!= NULL
)
6627 return ada_find_any_type (ada_encode (type_name
));
6637 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
6638 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
6639 The value stored in ARGS->name is valid until the next call to
6643 ada_tag_name_1 (void *args0
)
6645 struct tag_args
*args
= (struct tag_args
*) args0
;
6646 static char name
[1024];
6650 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
6653 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
6656 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6657 for (p
= name
; *p
!= '\0'; p
+= 1)
6664 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6668 ada_tag_name (struct value
*tag
)
6670 struct tag_args args
;
6671 if (!ada_is_tag_type (VALUE_TYPE (tag
)))
6675 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
6679 /* The parent type of TYPE, or NULL if none. */
6682 ada_parent_type (struct type
*type
)
6686 CHECK_TYPEDEF (type
);
6688 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6691 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6692 if (ada_is_parent_field (type
, i
))
6693 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
6698 /* True iff field number FIELD_NUM of structure type TYPE contains the
6699 parent-type (inherited) fields of a derived type. Assumes TYPE is
6700 a structure type with at least FIELD_NUM+1 fields. */
6703 ada_is_parent_field (struct type
*type
, int field_num
)
6705 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
6706 return (name
!= NULL
6707 && (strncmp (name
, "PARENT", 6) == 0
6708 || strncmp (name
, "_parent", 7) == 0));
6711 /* True iff field number FIELD_NUM of structure type TYPE is a
6712 transparent wrapper field (which should be silently traversed when doing
6713 field selection and flattened when printing). Assumes TYPE is a
6714 structure type with at least FIELD_NUM+1 fields. Such fields are always
6718 ada_is_wrapper_field (struct type
*type
, int field_num
)
6720 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6721 return (name
!= NULL
6722 && (strncmp (name
, "PARENT", 6) == 0
6723 || strcmp (name
, "REP") == 0
6724 || strncmp (name
, "_parent", 7) == 0
6725 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6728 /* True iff field number FIELD_NUM of structure or union type TYPE
6729 is a variant wrapper. Assumes TYPE is a structure type with at least
6730 FIELD_NUM+1 fields. */
6733 ada_is_variant_part (struct type
*type
, int field_num
)
6735 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6736 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6737 || (is_dynamic_field (type
, field_num
)
6738 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
6742 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6743 whose discriminants are contained in the record type OUTER_TYPE,
6744 returns the type of the controlling discriminant for the variant. */
6747 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6749 char *name
= ada_variant_discrim_name (var_type
);
6751 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
6753 return builtin_type_int
;
6758 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6759 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6760 represents a 'when others' clause; otherwise 0. */
6763 ada_is_others_clause (struct type
*type
, int field_num
)
6765 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6766 return (name
!= NULL
&& name
[0] == 'O');
6769 /* Assuming that TYPE0 is the type of the variant part of a record,
6770 returns the name of the discriminant controlling the variant.
6771 The value is valid until the next call to ada_variant_discrim_name. */
6774 ada_variant_discrim_name (struct type
*type0
)
6776 static char *result
= NULL
;
6777 static size_t result_len
= 0;
6780 const char *discrim_end
;
6781 const char *discrim_start
;
6783 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6784 type
= TYPE_TARGET_TYPE (type0
);
6788 name
= ada_type_name (type
);
6790 if (name
== NULL
|| name
[0] == '\000')
6793 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6796 if (strncmp (discrim_end
, "___XVN", 6) == 0)
6799 if (discrim_end
== name
)
6802 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6805 if (discrim_start
== name
+ 1)
6807 if ((discrim_start
> name
+ 3
6808 && strncmp (discrim_start
- 3, "___", 3) == 0)
6809 || discrim_start
[-1] == '.')
6813 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6814 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6815 result
[discrim_end
- discrim_start
] = '\0';
6819 /* Scan STR for a subtype-encoded number, beginning at position K.
6820 Put the position of the character just past the number scanned in
6821 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6822 Return 1 if there was a valid number at the given position, and 0
6823 otherwise. A "subtype-encoded" number consists of the absolute value
6824 in decimal, followed by the letter 'm' to indicate a negative number.
6825 Assumes 0m does not occur. */
6828 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6832 if (!isdigit (str
[k
]))
6835 /* Do it the hard way so as not to make any assumption about
6836 the relationship of unsigned long (%lu scan format code) and
6839 while (isdigit (str
[k
]))
6841 RU
= RU
* 10 + (str
[k
] - '0');
6848 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6854 /* NOTE on the above: Technically, C does not say what the results of
6855 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6856 number representable as a LONGEST (although either would probably work
6857 in most implementations). When RU>0, the locution in the then branch
6858 above is always equivalent to the negative of RU. */
6865 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6866 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6867 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6870 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6872 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6885 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6894 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6895 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6897 if (val
>= L
&& val
<= U
)
6909 /* FIXME: Lots of redundancy below. Try to consolidate. */
6911 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6912 ARG_TYPE, extract and return the value of one of its (non-static)
6913 fields. FIELDNO says which field. Differs from value_primitive_field
6914 only in that it can handle packed values of arbitrary type. */
6916 static struct value
*
6917 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6918 struct type
*arg_type
)
6922 CHECK_TYPEDEF (arg_type
);
6923 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
6925 /* Handle packed fields. */
6927 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
6929 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6930 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6932 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
6933 offset
+ bit_pos
/ 8,
6934 bit_pos
% 8, bit_size
, type
);
6937 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6940 /* Find field with name NAME in object of type TYPE. If found, return 1
6941 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
6942 OFFSET + the byte offset of the field within an object of that type,
6943 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
6944 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
6945 Looks inside wrappers for the field. Returns 0 if field not
6948 find_struct_field (char *name
, struct type
*type
, int offset
,
6949 struct type
**field_type_p
,
6950 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
6954 CHECK_TYPEDEF (type
);
6955 *field_type_p
= NULL
;
6956 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
6958 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
6960 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6961 int fld_offset
= offset
+ bit_pos
/ 8;
6962 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6964 if (t_field_name
== NULL
)
6967 else if (field_name_match (t_field_name
, name
))
6969 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6970 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6971 *byte_offset_p
= fld_offset
;
6972 *bit_offset_p
= bit_pos
% 8;
6973 *bit_size_p
= bit_size
;
6976 else if (ada_is_wrapper_field (type
, i
))
6978 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6979 field_type_p
, byte_offset_p
, bit_offset_p
,
6983 else if (ada_is_variant_part (type
, i
))
6986 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
6988 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6990 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6992 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6993 field_type_p
, byte_offset_p
,
6994 bit_offset_p
, bit_size_p
))
7004 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
7005 and search in it assuming it has (class) type TYPE.
7006 If found, return value, else return NULL.
7008 Searches recursively through wrapper fields (e.g., '_parent'). */
7010 static struct value
*
7011 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
7015 CHECK_TYPEDEF (type
);
7017 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
7019 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7021 if (t_field_name
== NULL
)
7024 else if (field_name_match (t_field_name
, name
))
7025 return ada_value_primitive_field (arg
, offset
, i
, type
);
7027 else if (ada_is_wrapper_field (type
, i
))
7029 struct value
*v
= /* Do not let indent join lines here. */
7030 ada_search_struct_field (name
, arg
,
7031 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
7032 TYPE_FIELD_TYPE (type
, i
));
7037 else if (ada_is_variant_part (type
, i
))
7040 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7041 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7043 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7045 struct value
*v
= ada_search_struct_field
/* Force line break. */
7047 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7048 TYPE_FIELD_TYPE (field_type
, j
));
7057 /* Given ARG, a value of type (pointer or reference to a)*
7058 structure/union, extract the component named NAME from the ultimate
7059 target structure/union and return it as a value with its
7060 appropriate type. If ARG is a pointer or reference and the field
7061 is not packed, returns a reference to the field, otherwise the
7062 value of the field (an lvalue if ARG is an lvalue).
7064 The routine searches for NAME among all members of the structure itself
7065 and (recursively) among all members of any wrapper members
7068 ERR is a name (for use in error messages) that identifies the class
7069 of entity that ARG is supposed to be. ERR may be null, indicating
7070 that on error, the function simply returns NULL, and does not
7071 throw an error. (FIXME: True only if ARG is a pointer or reference
7075 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
7077 struct type
*t
, *t1
;
7081 t1
= t
= check_typedef (VALUE_TYPE (arg
));
7082 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7084 t1
= TYPE_TARGET_TYPE (t
);
7090 error ("Bad value type in a %s.", err
);
7093 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7100 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7102 t1
= TYPE_TARGET_TYPE (t
);
7108 error ("Bad value type in a %s.", err
);
7111 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7113 arg
= value_ind (arg
);
7120 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7125 error ("Attempt to extract a component of a value that is not a %s.",
7130 v
= ada_search_struct_field (name
, arg
, 0, t
);
7133 int bit_offset
, bit_size
, byte_offset
;
7134 struct type
*field_type
;
7137 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7138 address
= value_as_address (arg
);
7140 address
= unpack_pointer (t
, VALUE_CONTENTS (arg
));
7142 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
7143 if (find_struct_field (name
, t1
, 0,
7144 &field_type
, &byte_offset
, &bit_offset
,
7149 arg
= ada_value_ind (arg
);
7150 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7151 bit_offset
, bit_size
,
7155 v
= value_from_pointer (lookup_reference_type (field_type
),
7156 address
+ byte_offset
);
7160 if (v
== NULL
&& err
!= NULL
)
7161 error ("There is no member named %s.", name
);
7166 /* Given a type TYPE, look up the type of the component of type named NAME.
7167 If DISPP is non-null, add its byte displacement from the beginning of a
7168 structure (pointed to by a value) of type TYPE to *DISPP (does not
7169 work for packed fields).
7171 Matches any field whose name has NAME as a prefix, possibly
7174 TYPE can be either a struct or union. If REFOK, TYPE may also
7175 be a (pointer or reference)+ to a struct or union, and the
7176 ultimate target type will be searched.
7178 Looks recursively into variant clauses and parent types.
7180 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7181 TYPE is not a type of the right kind. */
7183 static struct type
*
7184 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
7185 int noerr
, int *dispp
)
7192 if (refok
&& type
!= NULL
)
7195 CHECK_TYPEDEF (type
);
7196 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7197 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7199 type
= TYPE_TARGET_TYPE (type
);
7203 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7204 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7210 target_terminal_ours ();
7211 gdb_flush (gdb_stdout
);
7212 fprintf_unfiltered (gdb_stderr
, "Type ");
7214 fprintf_unfiltered (gdb_stderr
, "(null)");
7216 type_print (type
, "", gdb_stderr
, -1);
7217 error (" is not a structure or union type");
7221 type
= to_static_fixed_type (type
);
7223 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7225 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7229 if (t_field_name
== NULL
)
7232 else if (field_name_match (t_field_name
, name
))
7235 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
7236 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
7239 else if (ada_is_wrapper_field (type
, i
))
7242 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7247 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7252 else if (ada_is_variant_part (type
, i
))
7255 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7257 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7260 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
7265 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7276 target_terminal_ours ();
7277 gdb_flush (gdb_stdout
);
7278 fprintf_unfiltered (gdb_stderr
, "Type ");
7279 type_print (type
, "", gdb_stderr
, -1);
7280 fprintf_unfiltered (gdb_stderr
, " has no component named ");
7281 error ("%s", name
== NULL
? "<null>" : name
);
7287 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7288 within a value of type OUTER_TYPE that is stored in GDB at
7289 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7290 numbering from 0) is applicable. Returns -1 if none are. */
7293 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7294 char *outer_valaddr
)
7299 struct type
*discrim_type
;
7300 char *discrim_name
= ada_variant_discrim_name (var_type
);
7301 LONGEST discrim_val
;
7305 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
7306 if (discrim_type
== NULL
)
7308 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
7311 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7313 if (ada_is_others_clause (var_type
, i
))
7315 else if (ada_in_variant (discrim_val
, var_type
, i
))
7319 return others_clause
;
7324 /* Dynamic-Sized Records */
7326 /* Strategy: The type ostensibly attached to a value with dynamic size
7327 (i.e., a size that is not statically recorded in the debugging
7328 data) does not accurately reflect the size or layout of the value.
7329 Our strategy is to convert these values to values with accurate,
7330 conventional types that are constructed on the fly. */
7332 /* There is a subtle and tricky problem here. In general, we cannot
7333 determine the size of dynamic records without its data. However,
7334 the 'struct value' data structure, which GDB uses to represent
7335 quantities in the inferior process (the target), requires the size
7336 of the type at the time of its allocation in order to reserve space
7337 for GDB's internal copy of the data. That's why the
7338 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7339 rather than struct value*s.
7341 However, GDB's internal history variables ($1, $2, etc.) are
7342 struct value*s containing internal copies of the data that are not, in
7343 general, the same as the data at their corresponding addresses in
7344 the target. Fortunately, the types we give to these values are all
7345 conventional, fixed-size types (as per the strategy described
7346 above), so that we don't usually have to perform the
7347 'to_fixed_xxx_type' conversions to look at their values.
7348 Unfortunately, there is one exception: if one of the internal
7349 history variables is an array whose elements are unconstrained
7350 records, then we will need to create distinct fixed types for each
7351 element selected. */
7353 /* The upshot of all of this is that many routines take a (type, host
7354 address, target address) triple as arguments to represent a value.
7355 The host address, if non-null, is supposed to contain an internal
7356 copy of the relevant data; otherwise, the program is to consult the
7357 target at the target address. */
7359 /* Assuming that VAL0 represents a pointer value, the result of
7360 dereferencing it. Differs from value_ind in its treatment of
7361 dynamic-sized types. */
7364 ada_value_ind (struct value
*val0
)
7366 struct value
*val
= unwrap_value (value_ind (val0
));
7367 return ada_to_fixed_value (val
);
7370 /* The value resulting from dereferencing any "reference to"
7371 qualifiers on VAL0. */
7373 static struct value
*
7374 ada_coerce_ref (struct value
*val0
)
7376 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
7378 struct value
*val
= val0
;
7380 val
= unwrap_value (val
);
7381 return ada_to_fixed_value (val
);
7387 /* Return OFF rounded upward if necessary to a multiple of
7388 ALIGNMENT (a power of 2). */
7391 align_value (unsigned int off
, unsigned int alignment
)
7393 return (off
+ alignment
- 1) & ~(alignment
- 1);
7396 /* Return the bit alignment required for field #F of template type TYPE. */
7399 field_alignment (struct type
*type
, int f
)
7401 const char *name
= TYPE_FIELD_NAME (type
, f
);
7402 int len
= (name
== NULL
) ? 0 : strlen (name
);
7405 if (!isdigit (name
[len
- 1]))
7408 if (isdigit (name
[len
- 2]))
7409 align_offset
= len
- 2;
7411 align_offset
= len
- 1;
7413 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
7414 return TARGET_CHAR_BIT
;
7416 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7419 /* Find a symbol named NAME. Ignores ambiguity. */
7422 ada_find_any_symbol (const char *name
)
7426 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7427 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7430 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7434 /* Find a type named NAME. Ignores ambiguity. */
7437 ada_find_any_type (const char *name
)
7439 struct symbol
*sym
= ada_find_any_symbol (name
);
7442 return SYMBOL_TYPE (sym
);
7447 /* Given a symbol NAME and its associated BLOCK, search all symbols
7448 for its ___XR counterpart, which is the ``renaming'' symbol
7449 associated to NAME. Return this symbol if found, return
7453 ada_find_renaming_symbol (const char *name
, struct block
*block
)
7455 const struct symbol
*function_sym
= block_function (block
);
7458 if (function_sym
!= NULL
)
7460 /* If the symbol is defined inside a function, NAME is not fully
7461 qualified. This means we need to prepend the function name
7462 as well as adding the ``___XR'' suffix to build the name of
7463 the associated renaming symbol. */
7464 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
7465 const int function_name_len
= strlen (function_name
);
7466 const int rename_len
= function_name_len
+ 2 /* "__" */
7467 + strlen (name
) + 6 /* "___XR\0" */ ;
7469 /* Library-level functions are a special case, as GNAT adds
7470 a ``_ada_'' prefix to the function name to avoid namespace
7471 pollution. However, the renaming symbol themselves do not
7472 have this prefix, so we need to skip this prefix if present. */
7473 if (function_name_len
> 5 /* "_ada_" */
7474 && strstr (function_name
, "_ada_") == function_name
)
7475 function_name
= function_name
+ 5;
7477 rename
= (char *) alloca (rename_len
* sizeof (char));
7478 sprintf (rename
, "%s__%s___XR", function_name
, name
);
7482 const int rename_len
= strlen (name
) + 6;
7483 rename
= (char *) alloca (rename_len
* sizeof (char));
7484 sprintf (rename
, "%s___XR", name
);
7487 return ada_find_any_symbol (rename
);
7490 /* Because of GNAT encoding conventions, several GDB symbols may match a
7491 given type name. If the type denoted by TYPE0 is to be preferred to
7492 that of TYPE1 for purposes of type printing, return non-zero;
7493 otherwise return 0. */
7496 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7500 else if (type0
== NULL
)
7502 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
7504 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
7506 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
7508 else if (ada_is_packed_array_type (type0
))
7510 else if (ada_is_array_descriptor_type (type0
)
7511 && !ada_is_array_descriptor_type (type1
))
7513 else if (ada_renaming_type (type0
) != NULL
7514 && ada_renaming_type (type1
) == NULL
)
7519 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7520 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7523 ada_type_name (struct type
*type
)
7527 else if (TYPE_NAME (type
) != NULL
)
7528 return TYPE_NAME (type
);
7530 return TYPE_TAG_NAME (type
);
7533 /* Find a parallel type to TYPE whose name is formed by appending
7534 SUFFIX to the name of TYPE. */
7537 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7540 static size_t name_len
= 0;
7542 char *typename
= ada_type_name (type
);
7544 if (typename
== NULL
)
7547 len
= strlen (typename
);
7549 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
7551 strcpy (name
, typename
);
7552 strcpy (name
+ len
, suffix
);
7554 return ada_find_any_type (name
);
7558 /* If TYPE is a variable-size record type, return the corresponding template
7559 type describing its fields. Otherwise, return NULL. */
7561 static struct type
*
7562 dynamic_template_type (struct type
*type
)
7564 CHECK_TYPEDEF (type
);
7566 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
7567 || ada_type_name (type
) == NULL
)
7571 int len
= strlen (ada_type_name (type
));
7572 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7575 return ada_find_parallel_type (type
, "___XVE");
7579 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7580 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7583 is_dynamic_field (struct type
*templ_type
, int field_num
)
7585 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7587 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
7588 && strstr (name
, "___XVL") != NULL
;
7591 /* The index of the variant field of TYPE, or -1 if TYPE does not
7592 represent a variant record type. */
7595 variant_field_index (struct type
*type
)
7599 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
7602 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
7604 if (ada_is_variant_part (type
, f
))
7610 /* A record type with no fields. */
7612 static struct type
*
7613 empty_record (struct objfile
*objfile
)
7615 struct type
*type
= alloc_type (objfile
);
7616 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
7617 TYPE_NFIELDS (type
) = 0;
7618 TYPE_FIELDS (type
) = NULL
;
7619 TYPE_NAME (type
) = "<empty>";
7620 TYPE_TAG_NAME (type
) = NULL
;
7621 TYPE_FLAGS (type
) = 0;
7622 TYPE_LENGTH (type
) = 0;
7626 /* An ordinary record type (with fixed-length fields) that describes
7627 the value of type TYPE at VALADDR or ADDRESS (see comments at
7628 the beginning of this section) VAL according to GNAT conventions.
7629 DVAL0 should describe the (portion of a) record that contains any
7630 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
7631 an outer-level type (i.e., as opposed to a branch of a variant.) A
7632 variant field (unless unchecked) is replaced by a particular branch
7635 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7636 length are not statically known are discarded. As a consequence,
7637 VALADDR, ADDRESS and DVAL0 are ignored.
7639 NOTE: Limitations: For now, we assume that dynamic fields and
7640 variants occupy whole numbers of bytes. However, they need not be
7644 ada_template_to_fixed_record_type_1 (struct type
*type
, char *valaddr
,
7645 CORE_ADDR address
, struct value
*dval0
,
7646 int keep_dynamic_fields
)
7648 struct value
*mark
= value_mark ();
7651 int nfields
, bit_len
;
7654 int fld_bit_len
, bit_incr
;
7657 /* Compute the number of fields in this record type that are going
7658 to be processed: unless keep_dynamic_fields, this includes only
7659 fields whose position and length are static will be processed. */
7660 if (keep_dynamic_fields
)
7661 nfields
= TYPE_NFIELDS (type
);
7665 while (nfields
< TYPE_NFIELDS (type
)
7666 && !ada_is_variant_part (type
, nfields
)
7667 && !is_dynamic_field (type
, nfields
))
7671 rtype
= alloc_type (TYPE_OBJFILE (type
));
7672 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7673 INIT_CPLUS_SPECIFIC (rtype
);
7674 TYPE_NFIELDS (rtype
) = nfields
;
7675 TYPE_FIELDS (rtype
) = (struct field
*)
7676 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7677 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
7678 TYPE_NAME (rtype
) = ada_type_name (type
);
7679 TYPE_TAG_NAME (rtype
) = NULL
;
7680 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
7686 for (f
= 0; f
< nfields
; f
+= 1)
7690 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
7691 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
7692 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7694 if (ada_is_variant_part (type
, f
))
7697 fld_bit_len
= bit_incr
= 0;
7699 else if (is_dynamic_field (type
, f
))
7702 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7706 TYPE_FIELD_TYPE (rtype
, f
) =
7709 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
7710 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7711 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7712 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7713 bit_incr
= fld_bit_len
=
7714 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
7718 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
7719 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7720 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7721 bit_incr
= fld_bit_len
=
7722 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7724 bit_incr
= fld_bit_len
=
7725 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
7727 if (off
+ fld_bit_len
> bit_len
)
7728 bit_len
= off
+ fld_bit_len
;
7730 TYPE_LENGTH (rtype
) =
7731 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7734 /* We handle the variant part, if any, at the end because of certain
7735 odd cases in which it is re-ordered so as NOT the last field of
7736 the record. This can happen in the presence of representation
7738 if (variant_field
>= 0)
7740 struct type
*branch_type
;
7742 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7745 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7750 to_fixed_variant_branch_type
7751 (TYPE_FIELD_TYPE (type
, variant_field
),
7752 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7753 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7754 if (branch_type
== NULL
)
7756 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
7757 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7758 TYPE_NFIELDS (rtype
) -= 1;
7762 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7763 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7765 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
7767 if (off
+ fld_bit_len
> bit_len
)
7768 bit_len
= off
+ fld_bit_len
;
7769 TYPE_LENGTH (rtype
) =
7770 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7774 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
7776 value_free_to_mark (mark
);
7777 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7778 error ("record type with dynamic size is larger than varsize-limit");
7782 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7785 static struct type
*
7786 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
7787 CORE_ADDR address
, struct value
*dval0
)
7789 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7793 /* An ordinary record type in which ___XVL-convention fields and
7794 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7795 static approximations, containing all possible fields. Uses
7796 no runtime values. Useless for use in values, but that's OK,
7797 since the results are used only for type determinations. Works on both
7798 structs and unions. Representation note: to save space, we memorize
7799 the result of this function in the TYPE_TARGET_TYPE of the
7802 static struct type
*
7803 template_to_static_fixed_type (struct type
*type0
)
7809 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7810 return TYPE_TARGET_TYPE (type0
);
7812 nfields
= TYPE_NFIELDS (type0
);
7815 for (f
= 0; f
< nfields
; f
+= 1)
7817 struct type
*field_type
= CHECK_TYPEDEF (TYPE_FIELD_TYPE (type0
, f
));
7818 struct type
*new_type
;
7820 if (is_dynamic_field (type0
, f
))
7821 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7823 new_type
= to_static_fixed_type (field_type
);
7824 if (type
== type0
&& new_type
!= field_type
)
7826 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
7827 TYPE_CODE (type
) = TYPE_CODE (type0
);
7828 INIT_CPLUS_SPECIFIC (type
);
7829 TYPE_NFIELDS (type
) = nfields
;
7830 TYPE_FIELDS (type
) = (struct field
*)
7831 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7832 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7833 sizeof (struct field
) * nfields
);
7834 TYPE_NAME (type
) = ada_type_name (type0
);
7835 TYPE_TAG_NAME (type
) = NULL
;
7836 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
7837 TYPE_LENGTH (type
) = 0;
7839 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7840 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7845 /* Given an object of type TYPE whose contents are at VALADDR and
7846 whose address in memory is ADDRESS, returns a revision of TYPE --
7847 a non-dynamic-sized record with a variant part -- in which
7848 the variant part is replaced with the appropriate branch. Looks
7849 for discriminant values in DVAL0, which can be NULL if the record
7850 contains the necessary discriminant values. */
7852 static struct type
*
7853 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
7854 CORE_ADDR address
, struct value
*dval0
)
7856 struct value
*mark
= value_mark ();
7859 struct type
*branch_type
;
7860 int nfields
= TYPE_NFIELDS (type
);
7861 int variant_field
= variant_field_index (type
);
7863 if (variant_field
== -1)
7867 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7871 rtype
= alloc_type (TYPE_OBJFILE (type
));
7872 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7873 INIT_CPLUS_SPECIFIC (rtype
);
7874 TYPE_NFIELDS (rtype
) = nfields
;
7875 TYPE_FIELDS (rtype
) =
7876 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7877 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7878 sizeof (struct field
) * nfields
);
7879 TYPE_NAME (rtype
) = ada_type_name (type
);
7880 TYPE_TAG_NAME (rtype
) = NULL
;
7881 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
7882 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7884 branch_type
= to_fixed_variant_branch_type
7885 (TYPE_FIELD_TYPE (type
, variant_field
),
7886 cond_offset_host (valaddr
,
7887 TYPE_FIELD_BITPOS (type
, variant_field
)
7889 cond_offset_target (address
,
7890 TYPE_FIELD_BITPOS (type
, variant_field
)
7891 / TARGET_CHAR_BIT
), dval
);
7892 if (branch_type
== NULL
)
7895 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7896 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7897 TYPE_NFIELDS (rtype
) -= 1;
7901 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7902 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7903 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7904 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7906 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7908 value_free_to_mark (mark
);
7912 /* An ordinary record type (with fixed-length fields) that describes
7913 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7914 beginning of this section]. Any necessary discriminants' values
7915 should be in DVAL, a record value; it may be NULL if the object
7916 at ADDR itself contains any necessary discriminant values.
7917 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7918 values from the record are needed. Except in the case that DVAL,
7919 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7920 unchecked) is replaced by a particular branch of the variant.
7922 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7923 is questionable and may be removed. It can arise during the
7924 processing of an unconstrained-array-of-record type where all the
7925 variant branches have exactly the same size. This is because in
7926 such cases, the compiler does not bother to use the XVS convention
7927 when encoding the record. I am currently dubious of this
7928 shortcut and suspect the compiler should be altered. FIXME. */
7930 static struct type
*
7931 to_fixed_record_type (struct type
*type0
, char *valaddr
,
7932 CORE_ADDR address
, struct value
*dval
)
7934 struct type
*templ_type
;
7936 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
7939 templ_type
= dynamic_template_type (type0
);
7941 if (templ_type
!= NULL
)
7942 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7943 else if (variant_field_index (type0
) >= 0)
7945 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7947 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7952 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
7958 /* An ordinary record type (with fixed-length fields) that describes
7959 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7960 union type. Any necessary discriminants' values should be in DVAL,
7961 a record value. That is, this routine selects the appropriate
7962 branch of the union at ADDR according to the discriminant value
7963 indicated in the union's type name. */
7965 static struct type
*
7966 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
7967 CORE_ADDR address
, struct value
*dval
)
7970 struct type
*templ_type
;
7971 struct type
*var_type
;
7973 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7974 var_type
= TYPE_TARGET_TYPE (var_type0
);
7976 var_type
= var_type0
;
7978 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7980 if (templ_type
!= NULL
)
7981 var_type
= templ_type
;
7984 ada_which_variant_applies (var_type
,
7985 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
7988 return empty_record (TYPE_OBJFILE (var_type
));
7989 else if (is_dynamic_field (var_type
, which
))
7990 return to_fixed_record_type
7991 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7992 valaddr
, address
, dval
);
7993 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7995 to_fixed_record_type
7996 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7998 return TYPE_FIELD_TYPE (var_type
, which
);
8001 /* Assuming that TYPE0 is an array type describing the type of a value
8002 at ADDR, and that DVAL describes a record containing any
8003 discriminants used in TYPE0, returns a type for the value that
8004 contains no dynamic components (that is, no components whose sizes
8005 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
8006 true, gives an error message if the resulting type's size is over
8009 static struct type
*
8010 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
8013 struct type
*index_type_desc
;
8014 struct type
*result
;
8016 if (ada_is_packed_array_type (type0
) /* revisit? */
8017 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
8020 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
8021 if (index_type_desc
== NULL
)
8023 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
8024 /* NOTE: elt_type---the fixed version of elt_type0---should never
8025 depend on the contents of the array in properly constructed
8027 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
8029 if (elt_type0
== elt_type
)
8032 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
8033 elt_type
, TYPE_INDEX_TYPE (type0
));
8038 struct type
*elt_type0
;
8041 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8042 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8044 /* NOTE: result---the fixed version of elt_type0---should never
8045 depend on the contents of the array in properly constructed
8047 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
8048 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8050 struct type
*range_type
=
8051 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
8052 dval
, TYPE_OBJFILE (type0
));
8053 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
8054 result
, range_type
);
8056 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8057 error ("array type with dynamic size is larger than varsize-limit");
8060 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
8065 /* A standard type (containing no dynamically sized components)
8066 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8067 DVAL describes a record containing any discriminants used in TYPE0,
8068 and may be NULL if there are none, or if the object of type TYPE at
8069 ADDRESS or in VALADDR contains these discriminants. */
8072 ada_to_fixed_type (struct type
*type
, char *valaddr
,
8073 CORE_ADDR address
, struct value
*dval
)
8075 CHECK_TYPEDEF (type
);
8076 switch (TYPE_CODE (type
))
8080 case TYPE_CODE_STRUCT
:
8082 struct type
*static_type
= to_static_fixed_type (type
);
8083 if (ada_is_tagged_type (static_type
, 0))
8085 struct type
*real_type
=
8086 type_from_tag (value_tag_from_contents_and_address (static_type
,
8089 if (real_type
!= NULL
)
8092 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
8094 case TYPE_CODE_ARRAY
:
8095 return to_fixed_array_type (type
, dval
, 1);
8096 case TYPE_CODE_UNION
:
8100 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8104 /* A standard (static-sized) type corresponding as well as possible to
8105 TYPE0, but based on no runtime data. */
8107 static struct type
*
8108 to_static_fixed_type (struct type
*type0
)
8115 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
8118 CHECK_TYPEDEF (type0
);
8120 switch (TYPE_CODE (type0
))
8124 case TYPE_CODE_STRUCT
:
8125 type
= dynamic_template_type (type0
);
8127 return template_to_static_fixed_type (type
);
8129 return template_to_static_fixed_type (type0
);
8130 case TYPE_CODE_UNION
:
8131 type
= ada_find_parallel_type (type0
, "___XVU");
8133 return template_to_static_fixed_type (type
);
8135 return template_to_static_fixed_type (type0
);
8139 /* A static approximation of TYPE with all type wrappers removed. */
8141 static struct type
*
8142 static_unwrap_type (struct type
*type
)
8144 if (ada_is_aligner_type (type
))
8146 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
8147 if (ada_type_name (type1
) == NULL
)
8148 TYPE_NAME (type1
) = ada_type_name (type
);
8150 return static_unwrap_type (type1
);
8154 struct type
*raw_real_type
= ada_get_base_type (type
);
8155 if (raw_real_type
== type
)
8158 return to_static_fixed_type (raw_real_type
);
8162 /* In some cases, incomplete and private types require
8163 cross-references that are not resolved as records (for example,
8165 type FooP is access Foo;
8167 type Foo is array ...;
8168 ). In these cases, since there is no mechanism for producing
8169 cross-references to such types, we instead substitute for FooP a
8170 stub enumeration type that is nowhere resolved, and whose tag is
8171 the name of the actual type. Call these types "non-record stubs". */
8173 /* A type equivalent to TYPE that is not a non-record stub, if one
8174 exists, otherwise TYPE. */
8177 ada_completed_type (struct type
*type
)
8179 CHECK_TYPEDEF (type
);
8180 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
8181 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
8182 || TYPE_TAG_NAME (type
) == NULL
)
8186 char *name
= TYPE_TAG_NAME (type
);
8187 struct type
*type1
= ada_find_any_type (name
);
8188 return (type1
== NULL
) ? type
: type1
;
8192 /* A value representing the data at VALADDR/ADDRESS as described by
8193 type TYPE0, but with a standard (static-sized) type that correctly
8194 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8195 type, then return VAL0 [this feature is simply to avoid redundant
8196 creation of struct values]. */
8198 static struct value
*
8199 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8202 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
8203 if (type
== type0
&& val0
!= NULL
)
8206 return value_from_contents_and_address (type
, 0, address
);
8209 /* A value representing VAL, but with a standard (static-sized) type
8210 that correctly describes it. Does not necessarily create a new
8213 static struct value
*
8214 ada_to_fixed_value (struct value
*val
)
8216 return ada_to_fixed_value_create (VALUE_TYPE (val
),
8217 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
8221 /* If the PC is pointing inside a function prologue, then re-adjust it
8222 past this prologue. */
8225 adjust_pc_past_prologue (CORE_ADDR
*pc
)
8227 struct symbol
*func_sym
= find_pc_function (*pc
);
8231 const struct symtab_and_line sal
=
8232 find_function_start_sal (func_sym
, 1);
8239 /* A value representing VAL, but with a standard (static-sized) type
8240 chosen to approximate the real type of VAL as well as possible, but
8241 without consulting any runtime values. For Ada dynamic-sized
8242 types, therefore, the type of the result is likely to be inaccurate. */
8245 ada_to_static_fixed_value (struct value
*val
)
8248 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
8249 if (type
== VALUE_TYPE (val
))
8252 return coerce_unspec_val_to_type (val
, type
);
8258 /* Table mapping attribute numbers to names.
8259 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8261 static const char *attribute_names
[] = {
8279 ada_attribute_name (enum exp_opcode n
)
8281 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8282 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8284 return attribute_names
[0];
8287 /* Evaluate the 'POS attribute applied to ARG. */
8290 pos_atr (struct value
*arg
)
8292 struct type
*type
= VALUE_TYPE (arg
);
8294 if (!discrete_type_p (type
))
8295 error ("'POS only defined on discrete types");
8297 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8300 LONGEST v
= value_as_long (arg
);
8302 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
8304 if (v
== TYPE_FIELD_BITPOS (type
, i
))
8307 error ("enumeration value is invalid: can't find 'POS");
8310 return value_as_long (arg
);
8313 static struct value
*
8314 value_pos_atr (struct value
*arg
)
8316 return value_from_longest (builtin_type_ada_int
, pos_atr (arg
));
8319 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8321 static struct value
*
8322 value_val_atr (struct type
*type
, struct value
*arg
)
8324 if (!discrete_type_p (type
))
8325 error ("'VAL only defined on discrete types");
8326 if (!integer_type_p (VALUE_TYPE (arg
)))
8327 error ("'VAL requires integral argument");
8329 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8331 long pos
= value_as_long (arg
);
8332 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
8333 error ("argument to 'VAL out of range");
8334 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
8337 return value_from_longest (type
, value_as_long (arg
));
8343 /* True if TYPE appears to be an Ada character type.
8344 [At the moment, this is true only for Character and Wide_Character;
8345 It is a heuristic test that could stand improvement]. */
8348 ada_is_character_type (struct type
*type
)
8350 const char *name
= ada_type_name (type
);
8353 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
8354 || TYPE_CODE (type
) == TYPE_CODE_INT
8355 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8356 && (strcmp (name
, "character") == 0
8357 || strcmp (name
, "wide_character") == 0
8358 || strcmp (name
, "unsigned char") == 0);
8361 /* True if TYPE appears to be an Ada string type. */
8364 ada_is_string_type (struct type
*type
)
8366 CHECK_TYPEDEF (type
);
8368 && TYPE_CODE (type
) != TYPE_CODE_PTR
8369 && (ada_is_simple_array_type (type
)
8370 || ada_is_array_descriptor_type (type
))
8371 && ada_array_arity (type
) == 1)
8373 struct type
*elttype
= ada_array_element_type (type
, 1);
8375 return ada_is_character_type (elttype
);
8382 /* True if TYPE is a struct type introduced by the compiler to force the
8383 alignment of a value. Such types have a single field with a
8384 distinctive name. */
8387 ada_is_aligner_type (struct type
*type
)
8389 CHECK_TYPEDEF (type
);
8390 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
8391 && TYPE_NFIELDS (type
) == 1
8392 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
8395 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8396 the parallel type. */
8399 ada_get_base_type (struct type
*raw_type
)
8401 struct type
*real_type_namer
;
8402 struct type
*raw_real_type
;
8404 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
8407 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
8408 if (real_type_namer
== NULL
8409 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
8410 || TYPE_NFIELDS (real_type_namer
) != 1)
8413 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
8414 if (raw_real_type
== NULL
)
8417 return raw_real_type
;
8420 /* The type of value designated by TYPE, with all aligners removed. */
8423 ada_aligned_type (struct type
*type
)
8425 if (ada_is_aligner_type (type
))
8426 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
8428 return ada_get_base_type (type
);
8432 /* The address of the aligned value in an object at address VALADDR
8433 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
8436 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
8438 if (ada_is_aligner_type (type
))
8439 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
8441 TYPE_FIELD_BITPOS (type
,
8442 0) / TARGET_CHAR_BIT
);
8449 /* The printed representation of an enumeration literal with encoded
8450 name NAME. The value is good to the next call of ada_enum_name. */
8452 ada_enum_name (const char *name
)
8454 static char *result
;
8455 static size_t result_len
= 0;
8458 /* First, unqualify the enumeration name:
8459 1. Search for the last '.' character. If we find one, then skip
8460 all the preceeding characters, the unqualified name starts
8461 right after that dot.
8462 2. Otherwise, we may be debugging on a target where the compiler
8463 translates dots into "__". Search forward for double underscores,
8464 but stop searching when we hit an overloading suffix, which is
8465 of the form "__" followed by digits. */
8467 if ((tmp
= strrchr (name
, '.')) != NULL
)
8471 while ((tmp
= strstr (name
, "__")) != NULL
)
8473 if (isdigit (tmp
[2]))
8483 if (name
[1] == 'U' || name
[1] == 'W')
8485 if (sscanf (name
+ 2, "%x", &v
) != 1)
8491 GROW_VECT (result
, result_len
, 16);
8492 if (isascii (v
) && isprint (v
))
8493 sprintf (result
, "'%c'", v
);
8494 else if (name
[1] == 'U')
8495 sprintf (result
, "[\"%02x\"]", v
);
8497 sprintf (result
, "[\"%04x\"]", v
);
8503 if ((tmp
= strstr (name
, "__")) != NULL
8504 || (tmp
= strstr (name
, "$")) != NULL
)
8506 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
8507 strncpy (result
, name
, tmp
- name
);
8508 result
[tmp
- name
] = '\0';
8516 static struct value
*
8517 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
8520 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
8521 (expect_type
, exp
, pos
, noside
);
8524 /* Evaluate the subexpression of EXP starting at *POS as for
8525 evaluate_type, updating *POS to point just past the evaluated
8528 static struct value
*
8529 evaluate_subexp_type (struct expression
*exp
, int *pos
)
8531 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
8532 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8535 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8538 static struct value
*
8539 unwrap_value (struct value
*val
)
8541 struct type
*type
= check_typedef (VALUE_TYPE (val
));
8542 if (ada_is_aligner_type (type
))
8544 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
8545 NULL
, "internal structure");
8546 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
8547 if (ada_type_name (val_type
) == NULL
)
8548 TYPE_NAME (val_type
) = ada_type_name (type
);
8550 return unwrap_value (v
);
8554 struct type
*raw_real_type
=
8555 ada_completed_type (ada_get_base_type (type
));
8557 if (type
== raw_real_type
)
8561 coerce_unspec_val_to_type
8562 (val
, ada_to_fixed_type (raw_real_type
, 0,
8563 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
8568 static struct value
*
8569 cast_to_fixed (struct type
*type
, struct value
*arg
)
8573 if (type
== VALUE_TYPE (arg
))
8575 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
8576 val
= ada_float_to_fixed (type
,
8577 ada_fixed_to_float (VALUE_TYPE (arg
),
8578 value_as_long (arg
)));
8582 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
8583 val
= ada_float_to_fixed (type
, argd
);
8586 return value_from_longest (type
, val
);
8589 static struct value
*
8590 cast_from_fixed_to_double (struct value
*arg
)
8592 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
8593 value_as_long (arg
));
8594 return value_from_double (builtin_type_double
, val
);
8597 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8598 return the converted value. */
8600 static struct value
*
8601 coerce_for_assign (struct type
*type
, struct value
*val
)
8603 struct type
*type2
= VALUE_TYPE (val
);
8607 CHECK_TYPEDEF (type2
);
8608 CHECK_TYPEDEF (type
);
8610 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
8611 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8613 val
= ada_value_ind (val
);
8614 type2
= VALUE_TYPE (val
);
8617 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
8618 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8620 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
8621 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
8622 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
8623 error ("Incompatible types in assignment");
8624 VALUE_TYPE (val
) = type
;
8629 static struct value
*
8630 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
8633 struct type
*type1
, *type2
;
8638 type1
= base_type (check_typedef (VALUE_TYPE (arg1
)));
8639 type2
= base_type (check_typedef (VALUE_TYPE (arg2
)));
8641 if (TYPE_CODE (type1
) != TYPE_CODE_INT
8642 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
8643 return value_binop (arg1
, arg2
, op
);
8652 return value_binop (arg1
, arg2
, op
);
8655 v2
= value_as_long (arg2
);
8657 error ("second operand of %s must not be zero.", op_string (op
));
8659 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
8660 return value_binop (arg1
, arg2
, op
);
8662 v1
= value_as_long (arg1
);
8667 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
8668 v
+= v
> 0 ? -1 : 1;
8676 /* Should not reach this point. */
8680 val
= allocate_value (type1
);
8681 store_unsigned_integer (VALUE_CONTENTS_RAW (val
),
8682 TYPE_LENGTH (VALUE_TYPE (val
)), v
);
8687 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
8689 if (ada_is_direct_array_type (VALUE_TYPE (arg1
))
8690 || ada_is_direct_array_type (VALUE_TYPE (arg2
)))
8692 arg1
= ada_coerce_to_simple_array (arg1
);
8693 arg2
= ada_coerce_to_simple_array (arg2
);
8694 if (TYPE_CODE (VALUE_TYPE (arg1
)) != TYPE_CODE_ARRAY
8695 || TYPE_CODE (VALUE_TYPE (arg2
)) != TYPE_CODE_ARRAY
)
8696 error ("Attempt to compare array with non-array");
8697 /* FIXME: The following works only for types whose
8698 representations use all bits (no padding or undefined bits)
8699 and do not have user-defined equality. */
8701 TYPE_LENGTH (VALUE_TYPE (arg1
)) == TYPE_LENGTH (VALUE_TYPE (arg2
))
8702 && memcmp (VALUE_CONTENTS (arg1
), VALUE_CONTENTS (arg2
),
8703 TYPE_LENGTH (VALUE_TYPE (arg1
))) == 0;
8705 return value_equal (arg1
, arg2
);
8709 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8710 int *pos
, enum noside noside
)
8713 int tem
, tem2
, tem3
;
8715 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8718 struct value
**argvec
;
8722 op
= exp
->elts
[pc
].opcode
;
8729 unwrap_value (evaluate_subexp_standard
8730 (expect_type
, exp
, pos
, noside
));
8734 struct value
*result
;
8736 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8737 /* The result type will have code OP_STRING, bashed there from
8738 OP_ARRAY. Bash it back. */
8739 if (TYPE_CODE (VALUE_TYPE (result
)) == TYPE_CODE_STRING
)
8740 TYPE_CODE (VALUE_TYPE (result
)) = TYPE_CODE_ARRAY
;
8746 type
= exp
->elts
[pc
+ 1].type
;
8747 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8748 if (noside
== EVAL_SKIP
)
8750 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
8752 if (ada_is_fixed_point_type (type
))
8753 arg1
= cast_to_fixed (type
, arg1
);
8754 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8755 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
8756 else if (VALUE_LVAL (arg1
) == lval_memory
)
8758 /* This is in case of the really obscure (and undocumented,
8759 but apparently expected) case of (Foo) Bar.all, where Bar
8760 is an integer constant and Foo is a dynamic-sized type.
8761 If we don't do this, ARG1 will simply be relabeled with
8763 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8764 return value_zero (to_static_fixed_type (type
), not_lval
);
8766 ada_to_fixed_value_create
8767 (type
, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
8770 arg1
= value_cast (type
, arg1
);
8776 type
= exp
->elts
[pc
+ 1].type
;
8777 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8780 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8781 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
8782 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8784 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8785 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
8786 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8788 ("Fixed-point values must be assigned to fixed-point variables");
8790 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
8791 return ada_value_assign (arg1
, arg2
);
8794 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8795 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8796 if (noside
== EVAL_SKIP
)
8798 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
8799 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8800 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
8801 error ("Operands of fixed-point addition must have the same type");
8802 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
8805 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8806 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8807 if (noside
== EVAL_SKIP
)
8809 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
8810 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8811 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
8812 error ("Operands of fixed-point subtraction must have the same type");
8813 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
8817 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8818 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8819 if (noside
== EVAL_SKIP
)
8821 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8822 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8823 return value_zero (VALUE_TYPE (arg1
), not_lval
);
8826 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8827 arg1
= cast_from_fixed_to_double (arg1
);
8828 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8829 arg2
= cast_from_fixed_to_double (arg2
);
8830 return ada_value_binop (arg1
, arg2
, op
);
8835 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8836 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8837 if (noside
== EVAL_SKIP
)
8839 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8840 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8841 return value_zero (VALUE_TYPE (arg1
), not_lval
);
8843 return ada_value_binop (arg1
, arg2
, op
);
8846 case BINOP_NOTEQUAL
:
8847 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8848 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
8849 if (noside
== EVAL_SKIP
)
8851 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8854 tem
= ada_value_equal (arg1
, arg2
);
8855 if (op
== BINOP_NOTEQUAL
)
8857 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
8860 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8861 if (noside
== EVAL_SKIP
)
8863 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8864 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
8866 return value_neg (arg1
);
8870 if (noside
== EVAL_SKIP
)
8875 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8876 /* Only encountered when an unresolved symbol occurs in a
8877 context other than a function call, in which case, it is
8879 error ("Unexpected unresolved symbol, %s, during evaluation",
8880 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8881 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8885 (to_static_fixed_type
8886 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8892 unwrap_value (evaluate_subexp_standard
8893 (expect_type
, exp
, pos
, noside
));
8894 return ada_to_fixed_value (arg1
);
8900 /* Allocate arg vector, including space for the function to be
8901 called in argvec[0] and a terminating NULL. */
8902 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8904 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8906 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8907 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8908 error ("Unexpected unresolved symbol, %s, during evaluation",
8909 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8912 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8913 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8916 if (noside
== EVAL_SKIP
)
8920 if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec
[0]))))
8921 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8922 else if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
8923 || (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_ARRAY
8924 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8925 argvec
[0] = value_addr (argvec
[0]);
8927 type
= check_typedef (VALUE_TYPE (argvec
[0]));
8928 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8930 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
8932 case TYPE_CODE_FUNC
:
8933 type
= check_typedef (TYPE_TARGET_TYPE (type
));
8935 case TYPE_CODE_ARRAY
:
8937 case TYPE_CODE_STRUCT
:
8938 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8939 argvec
[0] = ada_value_ind (argvec
[0]);
8940 type
= check_typedef (TYPE_TARGET_TYPE (type
));
8943 error ("cannot subscript or call something of type `%s'",
8944 ada_type_name (VALUE_TYPE (argvec
[0])));
8949 switch (TYPE_CODE (type
))
8951 case TYPE_CODE_FUNC
:
8952 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8953 return allocate_value (TYPE_TARGET_TYPE (type
));
8954 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8955 case TYPE_CODE_STRUCT
:
8959 arity
= ada_array_arity (type
);
8960 type
= ada_array_element_type (type
, nargs
);
8962 error ("cannot subscript or call a record");
8964 error ("wrong number of subscripts; expecting %d", arity
);
8965 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8966 return allocate_value (ada_aligned_type (type
));
8968 unwrap_value (ada_value_subscript
8969 (argvec
[0], nargs
, argvec
+ 1));
8971 case TYPE_CODE_ARRAY
:
8972 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8974 type
= ada_array_element_type (type
, nargs
);
8976 error ("element type of array unknown");
8978 return allocate_value (ada_aligned_type (type
));
8981 unwrap_value (ada_value_subscript
8982 (ada_coerce_to_simple_array (argvec
[0]),
8983 nargs
, argvec
+ 1));
8984 case TYPE_CODE_PTR
: /* Pointer to array */
8985 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8986 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8988 type
= ada_array_element_type (type
, nargs
);
8990 error ("element type of array unknown");
8992 return allocate_value (ada_aligned_type (type
));
8995 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8996 nargs
, argvec
+ 1));
8999 error ("Internal error in evaluate_subexp");
9004 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9005 struct value
*low_bound_val
=
9006 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9007 LONGEST low_bound
= pos_atr (low_bound_val
);
9009 = pos_atr (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
9010 if (noside
== EVAL_SKIP
)
9013 /* If this is a reference to an aligner type, then remove all
9015 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
9016 && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
))))
9017 TYPE_TARGET_TYPE (VALUE_TYPE (array
)) =
9018 ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)));
9020 if (ada_is_packed_array_type (VALUE_TYPE (array
)))
9021 error ("cannot slice a packed array");
9023 /* If this is a reference to an array or an array lvalue,
9024 convert to a pointer. */
9025 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
9026 || (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_ARRAY
9027 && VALUE_LVAL (array
) == lval_memory
))
9028 array
= value_addr (array
);
9030 if (noside
== EVAL_AVOID_SIDE_EFFECTS
9031 && ada_is_array_descriptor_type (check_typedef
9032 (VALUE_TYPE (array
))))
9033 return empty_array (ada_type_of_array (array
, 0), low_bound
);
9035 array
= ada_coerce_to_simple_array_ptr (array
);
9037 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
)
9039 if (high_bound
< low_bound
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
9040 return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
9044 struct type
*arr_type0
=
9045 to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
9047 return ada_value_slice_ptr (array
, arr_type0
,
9048 (int) low_bound
, (int) high_bound
);
9051 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9053 else if (high_bound
< low_bound
)
9054 return empty_array (VALUE_TYPE (array
), low_bound
);
9056 return ada_value_slice (array
, (int) low_bound
, (int) high_bound
);
9061 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9062 type
= exp
->elts
[pc
+ 1].type
;
9064 if (noside
== EVAL_SKIP
)
9067 switch (TYPE_CODE (type
))
9070 lim_warning ("Membership test incompletely implemented; "
9071 "always returns true", 0);
9072 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
9074 case TYPE_CODE_RANGE
:
9075 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
9076 arg3
= value_from_longest (builtin_type_int
,
9077 TYPE_HIGH_BOUND (type
));
9079 value_from_longest (builtin_type_int
,
9080 (value_less (arg1
, arg3
)
9081 || value_equal (arg1
, arg3
))
9082 && (value_less (arg2
, arg1
)
9083 || value_equal (arg2
, arg1
)));
9086 case BINOP_IN_BOUNDS
:
9088 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9089 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9091 if (noside
== EVAL_SKIP
)
9094 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9095 return value_zero (builtin_type_int
, not_lval
);
9097 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9099 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg2
)))
9100 error ("invalid dimension number to '%s", "range");
9102 arg3
= ada_array_bound (arg2
, tem
, 1);
9103 arg2
= ada_array_bound (arg2
, tem
, 0);
9106 value_from_longest (builtin_type_int
,
9107 (value_less (arg1
, arg3
)
9108 || value_equal (arg1
, arg3
))
9109 && (value_less (arg2
, arg1
)
9110 || value_equal (arg2
, arg1
)));
9112 case TERNOP_IN_RANGE
:
9113 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9114 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9115 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9117 if (noside
== EVAL_SKIP
)
9121 value_from_longest (builtin_type_int
,
9122 (value_less (arg1
, arg3
)
9123 || value_equal (arg1
, arg3
))
9124 && (value_less (arg2
, arg1
)
9125 || value_equal (arg2
, arg1
)));
9131 struct type
*type_arg
;
9132 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9134 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9136 type_arg
= exp
->elts
[pc
+ 2].type
;
9140 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9144 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
9145 error ("illegal operand to '%s", ada_attribute_name (op
));
9146 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
9149 if (noside
== EVAL_SKIP
)
9152 if (type_arg
== NULL
)
9154 arg1
= ada_coerce_ref (arg1
);
9156 if (ada_is_packed_array_type (VALUE_TYPE (arg1
)))
9157 arg1
= ada_coerce_to_simple_array (arg1
);
9159 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg1
)))
9160 error ("invalid dimension number to '%s",
9161 ada_attribute_name (op
));
9163 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9165 type
= ada_index_type (VALUE_TYPE (arg1
), tem
);
9168 ("attempt to take bound of something that is not an array");
9169 return allocate_value (type
);
9174 default: /* Should never happen. */
9175 error ("unexpected attribute encountered");
9177 return ada_array_bound (arg1
, tem
, 0);
9179 return ada_array_bound (arg1
, tem
, 1);
9181 return ada_array_length (arg1
, tem
);
9184 else if (discrete_type_p (type_arg
))
9186 struct type
*range_type
;
9187 char *name
= ada_type_name (type_arg
);
9189 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
9191 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
9192 if (range_type
== NULL
)
9193 range_type
= type_arg
;
9197 error ("unexpected attribute encountered");
9199 return discrete_type_low_bound (range_type
);
9201 return discrete_type_high_bound (range_type
);
9203 error ("the 'length attribute applies only to array types");
9206 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
9207 error ("unimplemented type attribute");
9212 if (ada_is_packed_array_type (type_arg
))
9213 type_arg
= decode_packed_array_type (type_arg
);
9215 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
9216 error ("invalid dimension number to '%s",
9217 ada_attribute_name (op
));
9219 type
= ada_index_type (type_arg
, tem
);
9222 ("attempt to take bound of something that is not an array");
9223 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9224 return allocate_value (type
);
9229 error ("unexpected attribute encountered");
9231 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9232 return value_from_longest (type
, low
);
9234 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
9235 return value_from_longest (type
, high
);
9237 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9238 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
9239 return value_from_longest (type
, high
- low
+ 1);
9245 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9246 if (noside
== EVAL_SKIP
)
9249 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9250 return value_zero (ada_tag_type (arg1
), not_lval
);
9252 return ada_value_tag (arg1
);
9256 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9257 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9258 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9259 if (noside
== EVAL_SKIP
)
9261 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9262 return value_zero (VALUE_TYPE (arg1
), not_lval
);
9264 return value_binop (arg1
, arg2
,
9265 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9267 case OP_ATR_MODULUS
:
9269 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
9270 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9272 if (noside
== EVAL_SKIP
)
9275 if (!ada_is_modular_type (type_arg
))
9276 error ("'modulus must be applied to modular type");
9278 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9279 ada_modulus (type_arg
));
9284 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9285 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9286 if (noside
== EVAL_SKIP
)
9288 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9289 return value_zero (builtin_type_ada_int
, not_lval
);
9291 return value_pos_atr (arg1
);
9294 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9295 if (noside
== EVAL_SKIP
)
9297 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9298 return value_zero (builtin_type_ada_int
, not_lval
);
9300 return value_from_longest (builtin_type_ada_int
,
9302 * TYPE_LENGTH (VALUE_TYPE (arg1
)));
9305 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9306 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9307 type
= exp
->elts
[pc
+ 2].type
;
9308 if (noside
== EVAL_SKIP
)
9310 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9311 return value_zero (type
, not_lval
);
9313 return value_val_atr (type
, arg1
);
9316 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9317 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9318 if (noside
== EVAL_SKIP
)
9320 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9321 return value_zero (VALUE_TYPE (arg1
), not_lval
);
9323 return value_binop (arg1
, arg2
, op
);
9326 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9327 if (noside
== EVAL_SKIP
)
9333 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9334 if (noside
== EVAL_SKIP
)
9336 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
9337 return value_neg (arg1
);
9342 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
9343 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
9344 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
9345 if (noside
== EVAL_SKIP
)
9347 type
= check_typedef (VALUE_TYPE (arg1
));
9348 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9350 if (ada_is_array_descriptor_type (type
))
9351 /* GDB allows dereferencing GNAT array descriptors. */
9353 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9354 if (arrType
== NULL
)
9355 error ("Attempt to dereference null array pointer.");
9356 return value_at_lazy (arrType
, 0, NULL
);
9358 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9359 || TYPE_CODE (type
) == TYPE_CODE_REF
9360 /* In C you can dereference an array to get the 1st elt. */
9361 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9364 (to_static_fixed_type
9365 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
9367 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9368 /* GDB allows dereferencing an int. */
9369 return value_zero (builtin_type_int
, lval_memory
);
9371 error ("Attempt to take contents of a non-pointer value.");
9373 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9374 type
= check_typedef (VALUE_TYPE (arg1
));
9376 if (ada_is_array_descriptor_type (type
))
9377 /* GDB allows dereferencing GNAT array descriptors. */
9378 return ada_coerce_to_simple_array (arg1
);
9380 return ada_value_ind (arg1
);
9382 case STRUCTOP_STRUCT
:
9383 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9384 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9385 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9386 if (noside
== EVAL_SKIP
)
9388 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9390 struct type
*type1
= VALUE_TYPE (arg1
);
9391 if (ada_is_tagged_type (type1
, 1))
9393 type
= ada_lookup_struct_elt_type (type1
,
9394 &exp
->elts
[pc
+ 2].string
,
9397 /* In this case, we assume that the field COULD exist
9398 in some extension of the type. Return an object of
9399 "type" void, which will match any formal
9400 (see ada_type_match). */
9401 return value_zero (builtin_type_void
, lval_memory
);
9405 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9408 return value_zero (ada_aligned_type (type
), lval_memory
);
9412 ada_to_fixed_value (unwrap_value
9413 (ada_value_struct_elt
9414 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
9416 /* The value is not supposed to be used. This is here to make it
9417 easier to accommodate expressions that contain types. */
9419 if (noside
== EVAL_SKIP
)
9421 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9422 return allocate_value (builtin_type_void
);
9424 error ("Attempt to use a type name as an expression");
9428 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
9434 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9435 type name that encodes the 'small and 'delta information.
9436 Otherwise, return NULL. */
9439 fixed_type_info (struct type
*type
)
9441 const char *name
= ada_type_name (type
);
9442 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9444 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9446 const char *tail
= strstr (name
, "___XF_");
9452 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9453 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9458 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9461 ada_is_fixed_point_type (struct type
*type
)
9463 return fixed_type_info (type
) != NULL
;
9466 /* Return non-zero iff TYPE represents a System.Address type. */
9469 ada_is_system_address_type (struct type
*type
)
9471 return (TYPE_NAME (type
)
9472 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9475 /* Assuming that TYPE is the representation of an Ada fixed-point
9476 type, return its delta, or -1 if the type is malformed and the
9477 delta cannot be determined. */
9480 ada_delta (struct type
*type
)
9482 const char *encoding
= fixed_type_info (type
);
9485 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
9488 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
9491 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9492 factor ('SMALL value) associated with the type. */
9495 scaling_factor (struct type
*type
)
9497 const char *encoding
= fixed_type_info (type
);
9498 unsigned long num0
, den0
, num1
, den1
;
9501 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
9506 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
9508 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
9512 /* Assuming that X is the representation of a value of fixed-point
9513 type TYPE, return its floating-point equivalent. */
9516 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9518 return (DOUBLEST
) x
*scaling_factor (type
);
9521 /* The representation of a fixed-point value of type TYPE
9522 corresponding to the value X. */
9525 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9527 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9531 /* VAX floating formats */
9533 /* Non-zero iff TYPE represents one of the special VAX floating-point
9537 ada_is_vax_floating_type (struct type
*type
)
9540 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
9543 && (TYPE_CODE (type
) == TYPE_CODE_INT
9544 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9545 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
9548 /* The type of special VAX floating-point type this is, assuming
9549 ada_is_vax_floating_point. */
9552 ada_vax_float_type_suffix (struct type
*type
)
9554 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
9557 /* A value representing the special debugging function that outputs
9558 VAX floating-point values of the type represented by TYPE. Assumes
9559 ada_is_vax_floating_type (TYPE). */
9562 ada_vax_float_print_function (struct type
*type
)
9564 switch (ada_vax_float_type_suffix (type
))
9567 return get_var_value ("DEBUG_STRING_F", 0);
9569 return get_var_value ("DEBUG_STRING_D", 0);
9571 return get_var_value ("DEBUG_STRING_G", 0);
9573 error ("invalid VAX floating-point type");
9580 /* Scan STR beginning at position K for a discriminant name, and
9581 return the value of that discriminant field of DVAL in *PX. If
9582 PNEW_K is not null, put the position of the character beyond the
9583 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9584 not alter *PX and *PNEW_K if unsuccessful. */
9587 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9590 static char *bound_buffer
= NULL
;
9591 static size_t bound_buffer_len
= 0;
9594 struct value
*bound_val
;
9596 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9599 pend
= strstr (str
+ k
, "__");
9603 k
+= strlen (bound
);
9607 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9608 bound
= bound_buffer
;
9609 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9610 bound
[pend
- (str
+ k
)] = '\0';
9614 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
9615 if (bound_val
== NULL
)
9618 *px
= value_as_long (bound_val
);
9624 /* Value of variable named NAME in the current environment. If
9625 no such variable found, then if ERR_MSG is null, returns 0, and
9626 otherwise causes an error with message ERR_MSG. */
9628 static struct value
*
9629 get_var_value (char *name
, char *err_msg
)
9631 struct ada_symbol_info
*syms
;
9634 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9639 if (err_msg
== NULL
)
9642 error ("%s", err_msg
);
9645 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9648 /* Value of integer variable named NAME in the current environment. If
9649 no such variable found, returns 0, and sets *FLAG to 0. If
9650 successful, sets *FLAG to 1. */
9653 get_int_var_value (char *name
, int *flag
)
9655 struct value
*var_val
= get_var_value (name
, 0);
9667 return value_as_long (var_val
);
9672 /* Return a range type whose base type is that of the range type named
9673 NAME in the current environment, and whose bounds are calculated
9674 from NAME according to the GNAT range encoding conventions.
9675 Extract discriminant values, if needed, from DVAL. If a new type
9676 must be created, allocate in OBJFILE's space. The bounds
9677 information, in general, is encoded in NAME, the base type given in
9678 the named range type. */
9680 static struct type
*
9681 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9683 struct type
*raw_type
= ada_find_any_type (name
);
9684 struct type
*base_type
;
9687 if (raw_type
== NULL
)
9688 base_type
= builtin_type_int
;
9689 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9690 base_type
= TYPE_TARGET_TYPE (raw_type
);
9692 base_type
= raw_type
;
9694 subtype_info
= strstr (name
, "___XD");
9695 if (subtype_info
== NULL
)
9699 static char *name_buf
= NULL
;
9700 static size_t name_len
= 0;
9701 int prefix_len
= subtype_info
- name
;
9707 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9708 strncpy (name_buf
, name
, prefix_len
);
9709 name_buf
[prefix_len
] = '\0';
9712 bounds_str
= strchr (subtype_info
, '_');
9715 if (*subtype_info
== 'L')
9717 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9718 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9720 if (bounds_str
[n
] == '_')
9722 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9729 strcpy (name_buf
+ prefix_len
, "___L");
9730 L
= get_int_var_value (name_buf
, &ok
);
9733 lim_warning ("Unknown lower bound, using 1.", 1);
9738 if (*subtype_info
== 'U')
9740 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9741 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9747 strcpy (name_buf
+ prefix_len
, "___U");
9748 U
= get_int_var_value (name_buf
, &ok
);
9751 lim_warning ("Unknown upper bound, using %ld.", (long) L
);
9756 if (objfile
== NULL
)
9757 objfile
= TYPE_OBJFILE (base_type
);
9758 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9759 TYPE_NAME (type
) = name
;
9764 /* True iff NAME is the name of a range type. */
9767 ada_is_range_type_name (const char *name
)
9769 return (name
!= NULL
&& strstr (name
, "___XD"));
9775 /* True iff TYPE is an Ada modular type. */
9778 ada_is_modular_type (struct type
*type
)
9780 struct type
*subranged_type
= base_type (type
);
9782 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9783 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
9784 && TYPE_UNSIGNED (subranged_type
));
9787 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9790 ada_modulus (struct type
* type
)
9792 return TYPE_HIGH_BOUND (type
) + 1;
9796 /* Information about operators given special treatment in functions
9798 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
9800 #define ADA_OPERATORS \
9801 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
9802 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
9803 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
9804 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
9805 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
9806 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
9807 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
9808 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
9809 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
9810 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
9811 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
9812 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
9813 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
9814 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
9815 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
9816 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
9819 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
9821 switch (exp
->elts
[pc
- 1].opcode
)
9824 operator_length_standard (exp
, pc
, oplenp
, argsp
);
9827 #define OP_DEFN(op, len, args, binop) \
9828 case op: *oplenp = len; *argsp = args; break;
9835 ada_op_name (enum exp_opcode opcode
)
9840 return op_name_standard (opcode
);
9841 #define OP_DEFN(op, len, args, binop) case op: return #op;
9847 /* As for operator_length, but assumes PC is pointing at the first
9848 element of the operator, and gives meaningful results only for the
9849 Ada-specific operators. */
9852 ada_forward_operator_length (struct expression
*exp
, int pc
,
9853 int *oplenp
, int *argsp
)
9855 switch (exp
->elts
[pc
].opcode
)
9858 *oplenp
= *argsp
= 0;
9860 #define OP_DEFN(op, len, args, binop) \
9861 case op: *oplenp = len; *argsp = args; break;
9868 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
9870 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
9875 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
9879 /* Ada attributes ('Foo). */
9886 case OP_ATR_MODULUS
:
9895 fprintf_filtered (stream
, "Type @");
9896 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
9897 fprintf_filtered (stream
, " (");
9898 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
9899 fprintf_filtered (stream
, ")");
9901 case BINOP_IN_BOUNDS
:
9902 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
9904 case TERNOP_IN_RANGE
:
9908 return dump_subexp_body_standard (exp
, stream
, elt
);
9912 for (i
= 0; i
< nargs
; i
+= 1)
9913 elt
= dump_subexp (exp
, stream
, elt
);
9918 /* The Ada extension of print_subexp (q.v.). */
9921 ada_print_subexp (struct expression
*exp
, int *pos
,
9922 struct ui_file
*stream
, enum precedence prec
)
9926 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
9928 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9933 print_subexp_standard (exp
, pos
, stream
, prec
);
9938 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
9941 case BINOP_IN_BOUNDS
:
9943 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9944 fputs_filtered (" in ", stream
);
9945 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9946 fputs_filtered ("'range", stream
);
9947 if (exp
->elts
[pc
+ 1].longconst
> 1)
9948 fprintf_filtered (stream
, "(%ld)",
9949 (long) exp
->elts
[pc
+ 1].longconst
);
9952 case TERNOP_IN_RANGE
:
9954 if (prec
>= PREC_EQUAL
)
9955 fputs_filtered ("(", stream
);
9956 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9957 fputs_filtered (" in ", stream
);
9958 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
9959 fputs_filtered (" .. ", stream
);
9960 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
9961 if (prec
>= PREC_EQUAL
)
9962 fputs_filtered (")", stream
);
9971 case OP_ATR_MODULUS
:
9977 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9979 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
9980 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
9984 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9985 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
9989 for (tem
= 1; tem
< nargs
; tem
+= 1)
9991 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
9992 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
9994 fputs_filtered (")", stream
);
10000 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
10001 fputs_filtered ("'(", stream
);
10002 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10003 fputs_filtered (")", stream
);
10006 case UNOP_IN_RANGE
:
10008 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10009 fputs_filtered (" in ", stream
);
10010 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10015 /* Table mapping opcodes into strings for printing operators
10016 and precedences of the operators. */
10018 static const struct op_print ada_op_print_tab
[] = {
10019 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10020 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10021 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10022 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10023 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10024 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10025 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10026 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10027 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10028 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10029 {">", BINOP_GTR
, PREC_ORDER
, 0},
10030 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10031 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10032 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10033 {"+", BINOP_ADD
, PREC_ADD
, 0},
10034 {"-", BINOP_SUB
, PREC_ADD
, 0},
10035 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10036 {"*", BINOP_MUL
, PREC_MUL
, 0},
10037 {"/", BINOP_DIV
, PREC_MUL
, 0},
10038 {"rem", BINOP_REM
, PREC_MUL
, 0},
10039 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10040 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10041 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10042 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10043 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10044 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10045 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10046 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10047 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10048 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10049 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10053 /* Assorted Types and Interfaces */
10055 struct type
*builtin_type_ada_int
;
10056 struct type
*builtin_type_ada_short
;
10057 struct type
*builtin_type_ada_long
;
10058 struct type
*builtin_type_ada_long_long
;
10059 struct type
*builtin_type_ada_char
;
10060 struct type
*builtin_type_ada_float
;
10061 struct type
*builtin_type_ada_double
;
10062 struct type
*builtin_type_ada_long_double
;
10063 struct type
*builtin_type_ada_natural
;
10064 struct type
*builtin_type_ada_positive
;
10065 struct type
*builtin_type_ada_system_address
;
10067 struct type
**const (ada_builtin_types
[]) =
10069 &builtin_type_ada_int
,
10070 &builtin_type_ada_long
,
10071 &builtin_type_ada_short
,
10072 &builtin_type_ada_char
,
10073 &builtin_type_ada_float
,
10074 &builtin_type_ada_double
,
10075 &builtin_type_ada_long_long
,
10076 &builtin_type_ada_long_double
,
10077 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
10078 /* The following types are carried over from C for convenience. */
10080 &builtin_type_long
,
10081 &builtin_type_short
,
10082 &builtin_type_char
,
10083 &builtin_type_float
,
10084 &builtin_type_double
,
10085 &builtin_type_long_long
,
10086 &builtin_type_void
,
10087 &builtin_type_signed_char
,
10088 &builtin_type_unsigned_char
,
10089 &builtin_type_unsigned_short
,
10090 &builtin_type_unsigned_int
,
10091 &builtin_type_unsigned_long
,
10092 &builtin_type_unsigned_long_long
,
10093 &builtin_type_long_double
,
10094 &builtin_type_complex
, &builtin_type_double_complex
, 0};
10096 /* Not really used, but needed in the ada_language_defn. */
10099 emit_char (int c
, struct ui_file
*stream
, int quoter
)
10101 ada_emit_char (c
, stream
, quoter
, 1);
10107 warnings_issued
= 0;
10108 return ada_parse ();
10111 static const struct exp_descriptor ada_exp_descriptor
= {
10113 ada_operator_length
,
10115 ada_dump_subexp_body
,
10116 ada_evaluate_subexp
10119 const struct language_defn ada_language_defn
= {
10120 "ada", /* Language name */
10125 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
10126 that's not quite what this means. */
10129 ada_lookup_minimal_symbol
,
10130 #endif /* GNAT_GDB */
10131 &ada_exp_descriptor
,
10135 ada_printchar
, /* Print a character constant */
10136 ada_printstr
, /* Function to print string constant */
10137 emit_char
, /* Function to print single char (not used) */
10138 ada_create_fundamental_type
, /* Create fundamental type in this language */
10139 ada_print_type
, /* Print a type using appropriate syntax */
10140 ada_val_print
, /* Print a value using appropriate syntax */
10141 ada_value_print
, /* Print a top-level value */
10142 NULL
, /* Language specific skip_trampoline */
10143 NULL
, /* value_of_this */
10144 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
10145 basic_lookup_transparent_type
, /* lookup_transparent_type */
10146 ada_la_decode
, /* Language specific symbol demangler */
10147 NULL
, /* Language specific class_name_from_physname */
10148 {"", "", "", ""}, /* Binary format info */
10150 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
10151 {"%ld", "", "d", ""}, /* Decimal format info */
10152 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
10154 /* Copied from c-lang.c. */
10155 {"0%lo", "0", "o", ""}, /* Octal format info */
10156 {"%ld", "", "d", ""}, /* Decimal format info */
10157 {"0x%lx", "0x", "x", ""}, /* Hex format info */
10159 ada_op_print_tab
, /* expression operators for printing */
10160 0, /* c-style arrays */
10161 1, /* String lower bound */
10162 &builtin_type_ada_char
,
10163 ada_get_gdb_completer_word_break_characters
,
10165 ada_translate_error_message
, /* Substitute Ada-specific terminology
10166 in errors and warnings. */
10167 #endif /* GNAT_GDB */
10172 build_ada_types (void)
10174 builtin_type_ada_int
=
10175 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10176 0, "integer", (struct objfile
*) NULL
);
10177 builtin_type_ada_long
=
10178 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10179 0, "long_integer", (struct objfile
*) NULL
);
10180 builtin_type_ada_short
=
10181 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10182 0, "short_integer", (struct objfile
*) NULL
);
10183 builtin_type_ada_char
=
10184 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10185 0, "character", (struct objfile
*) NULL
);
10186 builtin_type_ada_float
=
10187 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
10188 0, "float", (struct objfile
*) NULL
);
10189 builtin_type_ada_double
=
10190 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10191 0, "long_float", (struct objfile
*) NULL
);
10192 builtin_type_ada_long_long
=
10193 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10194 0, "long_long_integer", (struct objfile
*) NULL
);
10195 builtin_type_ada_long_double
=
10196 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10197 0, "long_long_float", (struct objfile
*) NULL
);
10198 builtin_type_ada_natural
=
10199 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10200 0, "natural", (struct objfile
*) NULL
);
10201 builtin_type_ada_positive
=
10202 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10203 0, "positive", (struct objfile
*) NULL
);
10206 builtin_type_ada_system_address
=
10207 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10208 (struct objfile
*) NULL
));
10209 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
10213 _initialize_ada_language (void)
10216 build_ada_types ();
10217 deprecated_register_gdbarch_swap (NULL
, 0, build_ada_types
);
10218 add_language (&ada_language_defn
);
10220 varsize_limit
= 65536;
10223 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
10224 (char *) &varsize_limit
,
10225 "Set maximum bytes in dynamic-sized object.",
10226 &setlist
), &showlist
);
10227 obstack_init (&cache_space
);
10228 #endif /* GNAT_GDB */
10230 obstack_init (&symbol_list_obstack
);
10232 decoded_names_store
= htab_create_alloc_ex
10233 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
10234 NULL
, NULL
, xmcalloc
, xmfree
);
10237 /* Create a fundamental Ada type using default reasonable for the current
10240 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
10241 define fundamental types such as "int" or "double". Others (stabs or
10242 DWARF version 2, etc) do define fundamental types. For the formats which
10243 don't provide fundamental types, gdb can create such types using this
10246 FIXME: Some compilers distinguish explicitly signed integral types
10247 (signed short, signed int, signed long) from "regular" integral types
10248 (short, int, long) in the debugging information. There is some dis-
10249 agreement as to how useful this feature is. In particular, gcc does
10250 not support this. Also, only some debugging formats allow the
10251 distinction to be passed on to a debugger. For now, we always just
10252 use "short", "int", or "long" as the type name, for both the implicit
10253 and explicitly signed types. This also makes life easier for the
10254 gdb test suite since we don't have to account for the differences
10255 in output depending upon what the compiler and debugging format
10256 support. We will probably have to re-examine the issue when gdb
10257 starts taking it's fundamental type information directly from the
10258 debugging information supplied by the compiler. fnf@cygnus.com */
10260 static struct type
*
10261 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
10263 struct type
*type
= NULL
;
10268 /* FIXME: For now, if we are asked to produce a type not in this
10269 language, create the equivalent of a C integer type with the
10270 name "<?type?>". When all the dust settles from the type
10271 reconstruction work, this should probably become an error. */
10272 type
= init_type (TYPE_CODE_INT
,
10273 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10274 0, "<?type?>", objfile
);
10275 warning ("internal error: no Ada fundamental type %d", typeid);
10278 type
= init_type (TYPE_CODE_VOID
,
10279 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10280 0, "void", objfile
);
10283 type
= init_type (TYPE_CODE_INT
,
10284 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10285 0, "character", objfile
);
10287 case FT_SIGNED_CHAR
:
10288 type
= init_type (TYPE_CODE_INT
,
10289 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10290 0, "signed char", objfile
);
10292 case FT_UNSIGNED_CHAR
:
10293 type
= init_type (TYPE_CODE_INT
,
10294 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10295 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
10298 type
= init_type (TYPE_CODE_INT
,
10299 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10300 0, "short_integer", objfile
);
10302 case FT_SIGNED_SHORT
:
10303 type
= init_type (TYPE_CODE_INT
,
10304 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10305 0, "short_integer", objfile
);
10307 case FT_UNSIGNED_SHORT
:
10308 type
= init_type (TYPE_CODE_INT
,
10309 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10310 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
10313 type
= init_type (TYPE_CODE_INT
,
10314 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10315 0, "integer", objfile
);
10317 case FT_SIGNED_INTEGER
:
10318 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
10320 case FT_UNSIGNED_INTEGER
:
10321 type
= init_type (TYPE_CODE_INT
,
10322 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10323 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
10326 type
= init_type (TYPE_CODE_INT
,
10327 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10328 0, "long_integer", objfile
);
10330 case FT_SIGNED_LONG
:
10331 type
= init_type (TYPE_CODE_INT
,
10332 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10333 0, "long_integer", objfile
);
10335 case FT_UNSIGNED_LONG
:
10336 type
= init_type (TYPE_CODE_INT
,
10337 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10338 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
10341 type
= init_type (TYPE_CODE_INT
,
10342 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10343 0, "long_long_integer", objfile
);
10345 case FT_SIGNED_LONG_LONG
:
10346 type
= init_type (TYPE_CODE_INT
,
10347 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10348 0, "long_long_integer", objfile
);
10350 case FT_UNSIGNED_LONG_LONG
:
10351 type
= init_type (TYPE_CODE_INT
,
10352 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10353 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
10356 type
= init_type (TYPE_CODE_FLT
,
10357 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
10358 0, "float", objfile
);
10360 case FT_DBL_PREC_FLOAT
:
10361 type
= init_type (TYPE_CODE_FLT
,
10362 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10363 0, "long_float", objfile
);
10365 case FT_EXT_PREC_FLOAT
:
10366 type
= init_type (TYPE_CODE_FLT
,
10367 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10368 0, "long_long_float", objfile
);
10375 ada_dump_symtab (struct symtab
*s
)
10378 fprintf (stderr
, "New symtab: [\n");
10379 fprintf (stderr
, " Name: %s/%s;\n",
10380 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
10381 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
10382 if (s
->linetable
!= NULL
)
10384 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
10385 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
10387 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
10388 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
10391 fprintf (stderr
, "]\n");