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 /* If type is a record type in the form of a standard GNAT array
2174 descriptor, returns the number of dimensions for type. If arr is a
2175 simple array, returns the number of "array of"s that prefix its
2176 type designation. Otherwise, returns 0. */
2179 ada_array_arity (struct type
*type
)
2186 type
= desc_base_type (type
);
2189 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2190 return desc_arity (desc_bounds_type (type
));
2192 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2195 type
= check_typedef (TYPE_TARGET_TYPE (type
));
2201 /* If TYPE is a record type in the form of a standard GNAT array
2202 descriptor or a simple array type, returns the element type for
2203 TYPE after indexing by NINDICES indices, or by all indices if
2204 NINDICES is -1. Otherwise, returns NULL. */
2207 ada_array_element_type (struct type
*type
, int nindices
)
2209 type
= desc_base_type (type
);
2211 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
2214 struct type
*p_array_type
;
2216 p_array_type
= desc_data_type (type
);
2218 k
= ada_array_arity (type
);
2222 /* Initially p_array_type = elt_type(*)[]...(k times)...[]. */
2223 if (nindices
>= 0 && k
> nindices
)
2225 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
2226 while (k
> 0 && p_array_type
!= NULL
)
2228 p_array_type
= check_typedef (TYPE_TARGET_TYPE (p_array_type
));
2231 return p_array_type
;
2233 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2235 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
2237 type
= TYPE_TARGET_TYPE (type
);
2246 /* The type of nth index in arrays of given type (n numbering from 1).
2247 Does not examine memory. */
2250 ada_index_type (struct type
*type
, int n
)
2252 struct type
*result_type
;
2254 type
= desc_base_type (type
);
2256 if (n
> ada_array_arity (type
))
2259 if (ada_is_simple_array_type (type
))
2263 for (i
= 1; i
< n
; i
+= 1)
2264 type
= TYPE_TARGET_TYPE (type
);
2265 result_type
= TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
2266 /* FIXME: The stabs type r(0,0);bound;bound in an array type
2267 has a target type of TYPE_CODE_UNDEF. We compensate here, but
2268 perhaps stabsread.c would make more sense. */
2269 if (result_type
== NULL
|| TYPE_CODE (result_type
) == TYPE_CODE_UNDEF
)
2270 result_type
= builtin_type_int
;
2275 return desc_index_type (desc_bounds_type (type
), n
);
2278 /* Given that arr is an array type, returns the lower bound of the
2279 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
2280 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
2281 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
2282 bounds type. It works for other arrays with bounds supplied by
2283 run-time quantities other than discriminants. */
2286 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
2287 struct type
** typep
)
2290 struct type
*index_type_desc
;
2292 if (ada_is_packed_array_type (arr_type
))
2293 arr_type
= decode_packed_array_type (arr_type
);
2295 if (arr_type
== NULL
|| !ada_is_simple_array_type (arr_type
))
2298 *typep
= builtin_type_int
;
2299 return (LONGEST
) - which
;
2302 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
2303 type
= TYPE_TARGET_TYPE (arr_type
);
2307 index_type_desc
= ada_find_parallel_type (type
, "___XA");
2308 if (index_type_desc
== NULL
)
2310 struct type
*range_type
;
2311 struct type
*index_type
;
2315 type
= TYPE_TARGET_TYPE (type
);
2319 range_type
= TYPE_INDEX_TYPE (type
);
2320 index_type
= TYPE_TARGET_TYPE (range_type
);
2321 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
2322 index_type
= builtin_type_long
;
2324 *typep
= index_type
;
2326 (LONGEST
) (which
== 0
2327 ? TYPE_LOW_BOUND (range_type
)
2328 : TYPE_HIGH_BOUND (range_type
));
2332 struct type
*index_type
=
2333 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
2334 NULL
, TYPE_OBJFILE (arr_type
));
2336 *typep
= TYPE_TARGET_TYPE (index_type
);
2338 (LONGEST
) (which
== 0
2339 ? TYPE_LOW_BOUND (index_type
)
2340 : TYPE_HIGH_BOUND (index_type
));
2344 /* Given that arr is an array value, returns the lower bound of the
2345 nth index (numbering from 1) if which is 0, and the upper bound if
2346 which is 1. This routine will also work for arrays with bounds
2347 supplied by run-time quantities other than discriminants. */
2350 ada_array_bound (struct value
*arr
, int n
, int which
)
2352 struct type
*arr_type
= VALUE_TYPE (arr
);
2354 if (ada_is_packed_array_type (arr_type
))
2355 return ada_array_bound (decode_packed_array (arr
), n
, which
);
2356 else if (ada_is_simple_array_type (arr_type
))
2359 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
2360 return value_from_longest (type
, v
);
2363 return desc_one_bound (desc_bounds (arr
), n
, which
);
2366 /* Given that arr is an array value, returns the length of the
2367 nth index. This routine will also work for arrays with bounds
2368 supplied by run-time quantities other than discriminants.
2369 Does not work for arrays indexed by enumeration types with representation
2370 clauses at the moment. */
2373 ada_array_length (struct value
*arr
, int n
)
2375 struct type
*arr_type
= check_typedef (VALUE_TYPE (arr
));
2377 if (ada_is_packed_array_type (arr_type
))
2378 return ada_array_length (decode_packed_array (arr
), n
);
2380 if (ada_is_simple_array_type (arr_type
))
2384 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
2385 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
2386 return value_from_longest (type
, v
);
2390 value_from_longest (builtin_type_ada_int
,
2391 value_as_long (desc_one_bound (desc_bounds (arr
),
2393 - value_as_long (desc_one_bound (desc_bounds (arr
),
2397 /* An empty array whose type is that of ARR_TYPE (an array type),
2398 with bounds LOW to LOW-1. */
2400 static struct value
*
2401 empty_array (struct type
*arr_type
, int low
)
2403 return allocate_value (create_range_type (NULL
, TYPE_INDEX_TYPE (arr_type
),
2408 /* Name resolution */
2410 /* The "decoded" name for the user-definable Ada operator corresponding
2414 ada_decoded_op_name (enum exp_opcode op
)
2418 for (i
= 0; ada_opname_table
[i
].encoded
!= NULL
; i
+= 1)
2420 if (ada_opname_table
[i
].op
== op
)
2421 return ada_opname_table
[i
].decoded
;
2423 error ("Could not find operator name for opcode");
2427 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
2428 references (marked by OP_VAR_VALUE nodes in which the symbol has an
2429 undefined namespace) and converts operators that are
2430 user-defined into appropriate function calls. If CONTEXT_TYPE is
2431 non-null, it provides a preferred result type [at the moment, only
2432 type void has any effect---causing procedures to be preferred over
2433 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
2434 return type is preferred. May change (expand) *EXP. */
2437 resolve (struct expression
**expp
, int void_context_p
)
2441 resolve_subexp (expp
, &pc
, 1, void_context_p
? builtin_type_void
: NULL
);
2444 /* Resolve the operator of the subexpression beginning at
2445 position *POS of *EXPP. "Resolving" consists of replacing
2446 the symbols that have undefined namespaces in OP_VAR_VALUE nodes
2447 with their resolutions, replacing built-in operators with
2448 function calls to user-defined operators, where appropriate, and,
2449 when DEPROCEDURE_P is non-zero, converting function-valued variables
2450 into parameterless calls. May expand *EXPP. The CONTEXT_TYPE functions
2451 are as in ada_resolve, above. */
2453 static struct value
*
2454 resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
2455 struct type
*context_type
)
2459 struct expression
*exp
; /* Convenience: == *expp. */
2460 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
2461 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
2462 int nargs
; /* Number of operands. */
2468 /* Pass one: resolve operands, saving their types and updating *pos. */
2472 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2473 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2478 resolve_subexp (expp
, pos
, 0, NULL
);
2480 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2485 resolve_subexp (expp
, pos
, 1, exp
->elts
[pc
+ 1].type
);
2490 resolve_subexp (expp
, pos
, 0, NULL
);
2493 case OP_ATR_MODULUS
:
2523 arg1
= resolve_subexp (expp
, pos
, 0, NULL
);
2525 resolve_subexp (expp
, pos
, 1, NULL
);
2527 resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2545 case BINOP_LOGICAL_AND
:
2546 case BINOP_LOGICAL_OR
:
2547 case BINOP_BITWISE_AND
:
2548 case BINOP_BITWISE_IOR
:
2549 case BINOP_BITWISE_XOR
:
2552 case BINOP_NOTEQUAL
:
2559 case BINOP_SUBSCRIPT
:
2567 case UNOP_LOGICAL_NOT
:
2584 case OP_INTERNALVAR
:
2593 case STRUCTOP_STRUCT
:
2594 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2600 + BYTES_TO_EXP_ELEM (longest_to_int (exp
->elts
[pc
+ 1].longconst
)
2605 case TERNOP_IN_RANGE
:
2610 case BINOP_IN_BOUNDS
:
2616 error ("Unexpected operator during name resolution");
2619 argvec
= (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2620 for (i
= 0; i
< nargs
; i
+= 1)
2621 argvec
[i
] = resolve_subexp (expp
, pos
, 1, NULL
);
2625 /* Pass two: perform any resolution on principal operator. */
2632 if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
2634 struct ada_symbol_info
*candidates
;
2638 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2639 (exp
->elts
[pc
+ 2].symbol
),
2640 exp
->elts
[pc
+ 1].block
, VAR_DOMAIN
,
2643 if (n_candidates
> 1)
2645 /* Types tend to get re-introduced locally, so if there
2646 are any local symbols that are not types, first filter
2649 for (j
= 0; j
< n_candidates
; j
+= 1)
2650 switch (SYMBOL_CLASS (candidates
[j
].sym
))
2656 case LOC_REGPARM_ADDR
:
2660 case LOC_BASEREG_ARG
:
2662 case LOC_COMPUTED_ARG
:
2668 if (j
< n_candidates
)
2671 while (j
< n_candidates
)
2673 if (SYMBOL_CLASS (candidates
[j
].sym
) == LOC_TYPEDEF
)
2675 candidates
[j
] = candidates
[n_candidates
- 1];
2684 if (n_candidates
== 0)
2685 error ("No definition found for %s",
2686 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2687 else if (n_candidates
== 1)
2689 else if (deprocedure_p
2690 && !is_nonfunction (candidates
, n_candidates
))
2692 i
= ada_resolve_function
2693 (candidates
, n_candidates
, NULL
, 0,
2694 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 2].symbol
),
2697 error ("Could not find a match for %s",
2698 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2702 printf_filtered ("Multiple matches for %s\n",
2703 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
2704 user_select_syms (candidates
, n_candidates
, 1);
2708 exp
->elts
[pc
+ 1].block
= candidates
[i
].block
;
2709 exp
->elts
[pc
+ 2].symbol
= candidates
[i
].sym
;
2710 if (innermost_block
== NULL
2711 || contained_in (candidates
[i
].block
, innermost_block
))
2712 innermost_block
= candidates
[i
].block
;
2716 && (TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))
2719 replace_operator_with_call (expp
, pc
, 0, 0,
2720 exp
->elts
[pc
+ 2].symbol
,
2721 exp
->elts
[pc
+ 1].block
);
2728 if (exp
->elts
[pc
+ 3].opcode
== OP_VAR_VALUE
2729 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
2731 struct ada_symbol_info
*candidates
;
2735 ada_lookup_symbol_list (SYMBOL_LINKAGE_NAME
2736 (exp
->elts
[pc
+ 5].symbol
),
2737 exp
->elts
[pc
+ 4].block
, VAR_DOMAIN
,
2739 if (n_candidates
== 1)
2743 i
= ada_resolve_function
2744 (candidates
, n_candidates
,
2746 SYMBOL_LINKAGE_NAME (exp
->elts
[pc
+ 5].symbol
),
2749 error ("Could not find a match for %s",
2750 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
2753 exp
->elts
[pc
+ 4].block
= candidates
[i
].block
;
2754 exp
->elts
[pc
+ 5].symbol
= candidates
[i
].sym
;
2755 if (innermost_block
== NULL
2756 || contained_in (candidates
[i
].block
, innermost_block
))
2757 innermost_block
= candidates
[i
].block
;
2768 case BINOP_BITWISE_AND
:
2769 case BINOP_BITWISE_IOR
:
2770 case BINOP_BITWISE_XOR
:
2772 case BINOP_NOTEQUAL
:
2780 case UNOP_LOGICAL_NOT
:
2782 if (possible_user_operator_p (op
, argvec
))
2784 struct ada_symbol_info
*candidates
;
2788 ada_lookup_symbol_list (ada_encode (ada_decoded_op_name (op
)),
2789 (struct block
*) NULL
, VAR_DOMAIN
,
2791 i
= ada_resolve_function (candidates
, n_candidates
, argvec
, nargs
,
2792 ada_decoded_op_name (op
), NULL
);
2796 replace_operator_with_call (expp
, pc
, nargs
, 1,
2797 candidates
[i
].sym
, candidates
[i
].block
);
2807 return evaluate_subexp_type (exp
, pos
);
2810 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2811 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2812 a non-pointer. A type of 'void' (which is never a valid expression type)
2813 by convention matches anything. */
2814 /* The term "match" here is rather loose. The match is heuristic and
2815 liberal. FIXME: TOO liberal, in fact. */
2818 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2820 CHECK_TYPEDEF (ftype
);
2821 CHECK_TYPEDEF (atype
);
2823 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2824 ftype
= TYPE_TARGET_TYPE (ftype
);
2825 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2826 atype
= TYPE_TARGET_TYPE (atype
);
2828 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2829 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2832 switch (TYPE_CODE (ftype
))
2837 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2838 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2839 TYPE_TARGET_TYPE (atype
), 0);
2842 && ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2844 case TYPE_CODE_ENUM
:
2845 case TYPE_CODE_RANGE
:
2846 switch (TYPE_CODE (atype
))
2849 case TYPE_CODE_ENUM
:
2850 case TYPE_CODE_RANGE
:
2856 case TYPE_CODE_ARRAY
:
2857 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2858 || ada_is_array_descriptor_type (atype
));
2860 case TYPE_CODE_STRUCT
:
2861 if (ada_is_array_descriptor_type (ftype
))
2862 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2863 || ada_is_array_descriptor_type (atype
));
2865 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2866 && !ada_is_array_descriptor_type (atype
));
2868 case TYPE_CODE_UNION
:
2870 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2874 /* Return non-zero if the formals of FUNC "sufficiently match" the
2875 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2876 may also be an enumeral, in which case it is treated as a 0-
2877 argument function. */
2880 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2883 struct type
*func_type
= SYMBOL_TYPE (func
);
2885 if (SYMBOL_CLASS (func
) == LOC_CONST
2886 && TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2887 return (n_actuals
== 0);
2888 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2891 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2894 for (i
= 0; i
< n_actuals
; i
+= 1)
2896 if (actuals
[i
] == NULL
)
2900 struct type
*ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2901 struct type
*atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2903 if (!ada_type_match (ftype
, atype
, 1))
2910 /* False iff function type FUNC_TYPE definitely does not produce a value
2911 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2912 FUNC_TYPE is not a valid function type with a non-null return type
2913 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2916 return_match (struct type
*func_type
, struct type
*context_type
)
2918 struct type
*return_type
;
2920 if (func_type
== NULL
)
2923 if (TYPE_CODE (func_type
) == TYPE_CODE_FUNC
)
2924 return_type
= base_type (TYPE_TARGET_TYPE (func_type
));
2926 return_type
= base_type (func_type
);
2927 if (return_type
== NULL
)
2930 context_type
= base_type (context_type
);
2932 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2933 return context_type
== NULL
|| return_type
== context_type
;
2934 else if (context_type
== NULL
)
2935 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2937 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2941 /* Returns the index in SYMS[0..NSYMS-1] that contains the symbol for the
2942 function (if any) that matches the types of the NARGS arguments in
2943 ARGS. If CONTEXT_TYPE is non-null and there is at least one match
2944 that returns that type, then eliminate matches that don't. If
2945 CONTEXT_TYPE is void and there is at least one match that does not
2946 return void, eliminate all matches that do.
2948 Asks the user if there is more than one match remaining. Returns -1
2949 if there is no such symbol or none is selected. NAME is used
2950 solely for messages. May re-arrange and modify SYMS in
2951 the process; the index returned is for the modified vector. */
2954 ada_resolve_function (struct ada_symbol_info syms
[],
2955 int nsyms
, struct value
**args
, int nargs
,
2956 const char *name
, struct type
*context_type
)
2959 int m
; /* Number of hits */
2960 struct type
*fallback
;
2961 struct type
*return_type
;
2963 return_type
= context_type
;
2964 if (context_type
== NULL
)
2965 fallback
= builtin_type_void
;
2972 for (k
= 0; k
< nsyms
; k
+= 1)
2974 struct type
*type
= check_typedef (SYMBOL_TYPE (syms
[k
].sym
));
2976 if (ada_args_match (syms
[k
].sym
, args
, nargs
)
2977 && return_match (type
, return_type
))
2983 if (m
> 0 || return_type
== fallback
)
2986 return_type
= fallback
;
2993 printf_filtered ("Multiple matches for %s\n", name
);
2994 user_select_syms (syms
, m
, 1);
3000 /* Returns true (non-zero) iff decoded name N0 should appear before N1
3001 in a listing of choices during disambiguation (see sort_choices, below).
3002 The idea is that overloadings of a subprogram name from the
3003 same package should sort in their source order. We settle for ordering
3004 such symbols by their trailing number (__N or $N). */
3007 encoded_ordered_before (char *N0
, char *N1
)
3011 else if (N0
== NULL
)
3016 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
3018 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
3020 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
3021 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
3025 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
3028 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
3030 if (n0
== n1
&& strncmp (N0
, N1
, n0
) == 0)
3031 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
3033 return (strcmp (N0
, N1
) < 0);
3037 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by the
3041 sort_choices (struct ada_symbol_info syms
[], int nsyms
)
3044 for (i
= 1; i
< nsyms
; i
+= 1)
3046 struct ada_symbol_info sym
= syms
[i
];
3049 for (j
= i
- 1; j
>= 0; j
-= 1)
3051 if (encoded_ordered_before (SYMBOL_LINKAGE_NAME (syms
[j
].sym
),
3052 SYMBOL_LINKAGE_NAME (sym
.sym
)))
3054 syms
[j
+ 1] = syms
[j
];
3060 /* Given a list of NSYMS symbols in SYMS, select up to MAX_RESULTS>0
3061 by asking the user (if necessary), returning the number selected,
3062 and setting the first elements of SYMS items. Error if no symbols
3065 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
3066 to be re-integrated one of these days. */
3069 user_select_syms (struct ada_symbol_info
*syms
, int nsyms
, int max_results
)
3072 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
3074 int first_choice
= (max_results
== 1) ? 1 : 2;
3076 if (max_results
< 1)
3077 error ("Request to select 0 symbols!");
3081 printf_unfiltered ("[0] cancel\n");
3082 if (max_results
> 1)
3083 printf_unfiltered ("[1] all\n");
3085 sort_choices (syms
, nsyms
);
3087 for (i
= 0; i
< nsyms
; i
+= 1)
3089 if (syms
[i
].sym
== NULL
)
3092 if (SYMBOL_CLASS (syms
[i
].sym
) == LOC_BLOCK
)
3094 struct symtab_and_line sal
=
3095 find_function_start_sal (syms
[i
].sym
, 1);
3096 printf_unfiltered ("[%d] %s at %s:%d\n", i
+ first_choice
,
3097 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3099 ? "<no source file available>"
3100 : sal
.symtab
->filename
), sal
.line
);
3106 (SYMBOL_CLASS (syms
[i
].sym
) == LOC_CONST
3107 && SYMBOL_TYPE (syms
[i
].sym
) != NULL
3108 && TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) == TYPE_CODE_ENUM
);
3109 struct symtab
*symtab
= symtab_for_sym (syms
[i
].sym
);
3111 if (SYMBOL_LINE (syms
[i
].sym
) != 0 && symtab
!= NULL
)
3112 printf_unfiltered ("[%d] %s at %s:%d\n",
3114 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3115 symtab
->filename
, SYMBOL_LINE (syms
[i
].sym
));
3116 else if (is_enumeral
3117 && TYPE_NAME (SYMBOL_TYPE (syms
[i
].sym
)) != NULL
)
3119 printf_unfiltered ("[%d] ", i
+ first_choice
);
3120 ada_print_type (SYMBOL_TYPE (syms
[i
].sym
), NULL
,
3122 printf_unfiltered ("'(%s) (enumeral)\n",
3123 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3125 else if (symtab
!= NULL
)
3126 printf_unfiltered (is_enumeral
3127 ? "[%d] %s in %s (enumeral)\n"
3128 : "[%d] %s at %s:?\n",
3130 SYMBOL_PRINT_NAME (syms
[i
].sym
),
3133 printf_unfiltered (is_enumeral
3134 ? "[%d] %s (enumeral)\n"
3137 SYMBOL_PRINT_NAME (syms
[i
].sym
));
3141 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
3144 for (i
= 0; i
< n_chosen
; i
+= 1)
3145 syms
[i
] = syms
[chosen
[i
]];
3150 /* Read and validate a set of numeric choices from the user in the
3151 range 0 .. N_CHOICES-1. Place the results in increasing
3152 order in CHOICES[0 .. N-1], and return N.
3154 The user types choices as a sequence of numbers on one line
3155 separated by blanks, encoding them as follows:
3157 + A choice of 0 means to cancel the selection, throwing an error.
3158 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
3159 + The user chooses k by typing k+IS_ALL_CHOICE+1.
3161 The user is not allowed to choose more than MAX_RESULTS values.
3163 ANNOTATION_SUFFIX, if present, is used to annotate the input
3164 prompts (for use with the -f switch). */
3167 get_selections (int *choices
, int n_choices
, int max_results
,
3168 int is_all_choice
, char *annotation_suffix
)
3173 int first_choice
= is_all_choice
? 2 : 1;
3175 prompt
= getenv ("PS2");
3179 printf_unfiltered ("%s ", prompt
);
3180 gdb_flush (gdb_stdout
);
3182 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
3185 error_no_arg ("one or more choice numbers");
3189 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
3190 order, as given in args. Choices are validated. */
3196 while (isspace (*args
))
3198 if (*args
== '\0' && n_chosen
== 0)
3199 error_no_arg ("one or more choice numbers");
3200 else if (*args
== '\0')
3203 choice
= strtol (args
, &args2
, 10);
3204 if (args
== args2
|| choice
< 0
3205 || choice
> n_choices
+ first_choice
- 1)
3206 error ("Argument must be choice number");
3210 error ("cancelled");
3212 if (choice
< first_choice
)
3214 n_chosen
= n_choices
;
3215 for (j
= 0; j
< n_choices
; j
+= 1)
3219 choice
-= first_choice
;
3221 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
3225 if (j
< 0 || choice
!= choices
[j
])
3228 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
3229 choices
[k
+ 1] = choices
[k
];
3230 choices
[j
+ 1] = choice
;
3235 if (n_chosen
> max_results
)
3236 error ("Select no more than %d of the above", max_results
);
3241 /* Replace the operator of length OPLEN at position PC in *EXPP with a call
3242 on the function identified by SYM and BLOCK, and taking NARGS
3243 arguments. Update *EXPP as needed to hold more space. */
3246 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
3247 int oplen
, struct symbol
*sym
,
3248 struct block
*block
)
3250 /* A new expression, with 6 more elements (3 for funcall, 4 for function
3251 symbol, -oplen for operator being replaced). */
3252 struct expression
*newexp
= (struct expression
*)
3253 xmalloc (sizeof (struct expression
)
3254 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
3255 struct expression
*exp
= *expp
;
3257 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
3258 newexp
->language_defn
= exp
->language_defn
;
3259 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
3260 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
3261 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
3263 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
3264 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
3266 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
3267 newexp
->elts
[pc
+ 4].block
= block
;
3268 newexp
->elts
[pc
+ 5].symbol
= sym
;
3274 /* Type-class predicates */
3276 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type),
3280 numeric_type_p (struct type
*type
)
3286 switch (TYPE_CODE (type
))
3291 case TYPE_CODE_RANGE
:
3292 return (type
== TYPE_TARGET_TYPE (type
)
3293 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
3300 /* True iff TYPE is integral (an INT or RANGE of INTs). */
3303 integer_type_p (struct type
*type
)
3309 switch (TYPE_CODE (type
))
3313 case TYPE_CODE_RANGE
:
3314 return (type
== TYPE_TARGET_TYPE (type
)
3315 || integer_type_p (TYPE_TARGET_TYPE (type
)));
3322 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
3325 scalar_type_p (struct type
*type
)
3331 switch (TYPE_CODE (type
))
3334 case TYPE_CODE_RANGE
:
3335 case TYPE_CODE_ENUM
:
3344 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
3347 discrete_type_p (struct type
*type
)
3353 switch (TYPE_CODE (type
))
3356 case TYPE_CODE_RANGE
:
3357 case TYPE_CODE_ENUM
:
3365 /* Returns non-zero if OP with operands in the vector ARGS could be
3366 a user-defined function. Errs on the side of pre-defined operators
3367 (i.e., result 0). */
3370 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
3372 struct type
*type0
=
3373 (args
[0] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[0]));
3374 struct type
*type1
=
3375 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
3389 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
3393 case BINOP_BITWISE_AND
:
3394 case BINOP_BITWISE_IOR
:
3395 case BINOP_BITWISE_XOR
:
3396 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
3399 case BINOP_NOTEQUAL
:
3404 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
3408 ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
3409 && (TYPE_CODE (type0
) != TYPE_CODE_PTR
3410 || TYPE_CODE (TYPE_TARGET_TYPE (type0
)) != TYPE_CODE_ARRAY
))
3411 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
3412 && (TYPE_CODE (type1
) != TYPE_CODE_PTR
3413 || (TYPE_CODE (TYPE_TARGET_TYPE (type1
)) !=
3414 TYPE_CODE_ARRAY
))));
3417 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
3421 case UNOP_LOGICAL_NOT
:
3423 return (!numeric_type_p (type0
));
3430 /* NOTE: In the following, we assume that a renaming type's name may
3431 have an ___XD suffix. It would be nice if this went away at some
3434 /* If TYPE encodes a renaming, returns the renaming suffix, which
3435 is XR for an object renaming, XRP for a procedure renaming, XRE for
3436 an exception renaming, and XRS for a subprogram renaming. Returns
3437 NULL if NAME encodes none of these. */
3440 ada_renaming_type (struct type
*type
)
3442 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
3444 const char *name
= type_name_no_tag (type
);
3445 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
3447 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
3456 /* Return non-zero iff SYM encodes an object renaming. */
3459 ada_is_object_renaming (struct symbol
*sym
)
3461 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
3462 return renaming_type
!= NULL
3463 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
3466 /* Assuming that SYM encodes a non-object renaming, returns the original
3467 name of the renamed entity. The name is good until the end of
3471 ada_simple_renamed_entity (struct symbol
*sym
)
3474 const char *raw_name
;
3478 type
= SYMBOL_TYPE (sym
);
3479 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
3480 error ("Improperly encoded renaming.");
3482 raw_name
= TYPE_FIELD_NAME (type
, 0);
3483 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3485 error ("Improperly encoded renaming.");
3487 result
= xmalloc (len
+ 1);
3488 strncpy (result
, raw_name
, len
);
3489 result
[len
] = '\000';
3494 /* Evaluation: Function Calls */
3496 /* Return an lvalue containing the value VAL. This is the identity on
3497 lvalues, and otherwise has the side-effect of pushing a copy of VAL
3498 on the stack, using and updating *SP as the stack pointer, and
3499 returning an lvalue whose VALUE_ADDRESS points to the copy. */
3501 static struct value
*
3502 ensure_lval (struct value
*val
, CORE_ADDR
*sp
)
3504 CORE_ADDR old_sp
= *sp
;
3506 if (VALUE_LVAL (val
))
3509 if (DEPRECATED_STACK_ALIGN_P ())
3510 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3511 DEPRECATED_STACK_ALIGN
3512 (TYPE_LENGTH (check_typedef (VALUE_TYPE (val
)))));
3514 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3515 TYPE_LENGTH (check_typedef (VALUE_TYPE (val
))));
3517 VALUE_LVAL (val
) = lval_memory
;
3518 if (INNER_THAN (1, 2))
3519 VALUE_ADDRESS (val
) = *sp
;
3521 VALUE_ADDRESS (val
) = old_sp
;
3526 /* Return the value ACTUAL, converted to be an appropriate value for a
3527 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3528 allocating any necessary descriptors (fat pointers), or copies of
3529 values not residing in memory, updating it as needed. */
3531 static struct value
*
3532 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3535 struct type
*actual_type
= check_typedef (VALUE_TYPE (actual
));
3536 struct type
*formal_type
= check_typedef (formal_type0
);
3537 struct type
*formal_target
=
3538 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3539 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3540 struct type
*actual_target
=
3541 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3542 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3544 if (ada_is_array_descriptor_type (formal_target
)
3545 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3546 return make_array_descriptor (formal_type
, actual
, sp
);
3547 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3549 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3550 && ada_is_array_descriptor_type (actual_target
))
3551 return desc_data (actual
);
3552 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3554 if (VALUE_LVAL (actual
) != lval_memory
)
3557 actual_type
= check_typedef (VALUE_TYPE (actual
));
3558 val
= allocate_value (actual_type
);
3559 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3560 (char *) VALUE_CONTENTS (actual
),
3561 TYPE_LENGTH (actual_type
));
3562 actual
= ensure_lval (val
, sp
);
3564 return value_addr (actual
);
3567 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3568 return ada_value_ind (actual
);
3574 /* Push a descriptor of type TYPE for array value ARR on the stack at
3575 *SP, updating *SP to reflect the new descriptor. Return either
3576 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3577 to-descriptor type rather than a descriptor type), a struct value *
3578 representing a pointer to this descriptor. */
3580 static struct value
*
3581 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3583 struct type
*bounds_type
= desc_bounds_type (type
);
3584 struct type
*desc_type
= desc_base_type (type
);
3585 struct value
*descriptor
= allocate_value (desc_type
);
3586 struct value
*bounds
= allocate_value (bounds_type
);
3589 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3591 modify_general_field (VALUE_CONTENTS (bounds
),
3592 value_as_long (ada_array_bound (arr
, i
, 0)),
3593 desc_bound_bitpos (bounds_type
, i
, 0),
3594 desc_bound_bitsize (bounds_type
, i
, 0));
3595 modify_general_field (VALUE_CONTENTS (bounds
),
3596 value_as_long (ada_array_bound (arr
, i
, 1)),
3597 desc_bound_bitpos (bounds_type
, i
, 1),
3598 desc_bound_bitsize (bounds_type
, i
, 1));
3601 bounds
= ensure_lval (bounds
, sp
);
3603 modify_general_field (VALUE_CONTENTS (descriptor
),
3604 VALUE_ADDRESS (ensure_lval (arr
, sp
)),
3605 fat_pntr_data_bitpos (desc_type
),
3606 fat_pntr_data_bitsize (desc_type
));
3608 modify_general_field (VALUE_CONTENTS (descriptor
),
3609 VALUE_ADDRESS (bounds
),
3610 fat_pntr_bounds_bitpos (desc_type
),
3611 fat_pntr_bounds_bitsize (desc_type
));
3613 descriptor
= ensure_lval (descriptor
, sp
);
3615 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3616 return value_addr (descriptor
);
3622 /* Assuming a dummy frame has been established on the target, perform any
3623 conversions needed for calling function FUNC on the NARGS actual
3624 parameters in ARGS, other than standard C conversions. Does
3625 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3626 does not match the number of arguments expected. Use *SP as a
3627 stack pointer for additional data that must be pushed, updating its
3631 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3636 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3637 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3640 for (i
= 0; i
< nargs
; i
+= 1)
3642 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3645 /* Experimental Symbol Cache Module */
3647 /* This module may well have been OBE, due to improvements in the
3648 symbol-table module. So until proven otherwise, it is disabled in
3649 the submitted public code, and may be removed from all sources
3654 /* This section implements a simple, fixed-sized hash table for those
3655 Ada-mode symbols that get looked up in the course of executing the user's
3656 commands. The size is fixed on the grounds that there are not
3657 likely to be all that many symbols looked up during any given
3658 session, regardless of the size of the symbol table. If we decide
3659 to go to a resizable table, let's just use the stuff from libiberty
3662 #define HASH_SIZE 1009
3667 domain_enum
namespace;
3669 struct symtab
*symtab
;
3670 struct block
*block
;
3671 struct cache_entry
*next
;
3674 static struct obstack cache_space
;
3676 static struct cache_entry
*cache
[HASH_SIZE
];
3678 /* Clear all entries from the symbol cache. */
3681 clear_ada_sym_cache (void)
3683 obstack_free (&cache_space
, NULL
);
3684 obstack_init (&cache_space
);
3685 memset (cache
, '\000', sizeof (cache
));
3688 static struct cache_entry
**
3689 find_entry (const char *name
, domain_enum
namespace)
3691 int h
= msymbol_hash (name
) % HASH_SIZE
;
3692 struct cache_entry
**e
;
3693 for (e
= &cache
[h
]; *e
!= NULL
; e
= &(*e
)->next
)
3695 if (namespace == (*e
)->namespace && strcmp (name
, (*e
)->name
) == 0)
3701 /* Return (in SYM) the last cached definition for global or static symbol NAME
3702 in namespace DOMAIN. Returns 1 if entry found, 0 otherwise.
3703 If SYMTAB is non-NULL, store the symbol
3704 table in which the symbol was found there, or NULL if not found.
3705 *BLOCK is set to the block in which NAME is found. */
3708 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3709 struct symbol
**sym
, struct block
**block
,
3710 struct symtab
**symtab
)
3712 struct cache_entry
**e
= find_entry (name
, namespace);
3718 *block
= (*e
)->block
;
3720 *symtab
= (*e
)->symtab
;
3724 /* Set the cached definition of NAME in DOMAIN to SYM in block
3725 BLOCK and symbol table SYMTAB. */
3728 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3729 struct block
*block
, struct symtab
*symtab
)
3731 int h
= msymbol_hash (name
) % HASH_SIZE
;
3733 struct cache_entry
*e
=
3734 (struct cache_entry
*) obstack_alloc (&cache_space
, sizeof (*e
));
3737 e
->name
= copy
= obstack_alloc (&cache_space
, strlen (name
) + 1);
3738 strcpy (copy
, name
);
3740 e
->namespace = namespace;
3747 lookup_cached_symbol (const char *name
, domain_enum
namespace,
3748 struct symbol
**sym
, struct block
**block
,
3749 struct symtab
**symtab
)
3755 cache_symbol (const char *name
, domain_enum
namespace, struct symbol
*sym
,
3756 struct block
*block
, struct symtab
*symtab
)
3759 #endif /* GNAT_GDB */
3763 /* Return the result of a standard (literal, C-like) lookup of NAME in
3764 given DOMAIN, visible from lexical block BLOCK. */
3766 static struct symbol
*
3767 standard_lookup (const char *name
, const struct block
*block
,
3771 struct symtab
*symtab
;
3773 if (lookup_cached_symbol (name
, domain
, &sym
, NULL
, NULL
))
3776 lookup_symbol_in_language (name
, block
, domain
, language_c
, 0, &symtab
);
3777 cache_symbol (name
, domain
, sym
, block_found
, symtab
);
3782 /* Non-zero iff there is at least one non-function/non-enumeral symbol
3783 in the symbol fields of SYMS[0..N-1]. We treat enumerals as functions,
3784 since they contend in overloading in the same way. */
3786 is_nonfunction (struct ada_symbol_info syms
[], int n
)
3790 for (i
= 0; i
< n
; i
+= 1)
3791 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_FUNC
3792 && (TYPE_CODE (SYMBOL_TYPE (syms
[i
].sym
)) != TYPE_CODE_ENUM
3793 || SYMBOL_CLASS (syms
[i
].sym
) != LOC_CONST
))
3799 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3800 struct types. Otherwise, they may not. */
3803 equiv_types (struct type
*type0
, struct type
*type1
)
3807 if (type0
== NULL
|| type1
== NULL
3808 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3810 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3811 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3812 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3813 && strcmp (ada_type_name (type0
), ada_type_name (type1
)) == 0)
3819 /* True iff SYM0 represents the same entity as SYM1, or one that is
3820 no more defined than that of SYM1. */
3823 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3827 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3828 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3831 switch (SYMBOL_CLASS (sym0
))
3837 struct type
*type0
= SYMBOL_TYPE (sym0
);
3838 struct type
*type1
= SYMBOL_TYPE (sym1
);
3839 char *name0
= SYMBOL_LINKAGE_NAME (sym0
);
3840 char *name1
= SYMBOL_LINKAGE_NAME (sym1
);
3841 int len0
= strlen (name0
);
3843 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3844 && (equiv_types (type0
, type1
)
3845 || (len0
< strlen (name1
) && strncmp (name0
, name1
, len0
) == 0
3846 && strncmp (name1
+ len0
, "___XV", 5) == 0));
3849 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3850 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3856 /* Append (SYM,BLOCK,SYMTAB) to the end of the array of struct ada_symbol_info
3857 records in OBSTACKP. Do nothing if SYM is a duplicate. */
3860 add_defn_to_vec (struct obstack
*obstackp
,
3862 struct block
*block
, struct symtab
*symtab
)
3866 struct ada_symbol_info
*prevDefns
= defns_collected (obstackp
, 0);
3868 if (SYMBOL_TYPE (sym
) != NULL
)
3869 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3870 for (i
= num_defns_collected (obstackp
) - 1; i
>= 0; i
-= 1)
3872 if (lesseq_defined_than (sym
, prevDefns
[i
].sym
))
3874 else if (lesseq_defined_than (prevDefns
[i
].sym
, sym
))
3876 prevDefns
[i
].sym
= sym
;
3877 prevDefns
[i
].block
= block
;
3878 prevDefns
[i
].symtab
= symtab
;
3884 struct ada_symbol_info info
;
3888 info
.symtab
= symtab
;
3889 obstack_grow (obstackp
, &info
, sizeof (struct ada_symbol_info
));
3893 /* Number of ada_symbol_info structures currently collected in
3894 current vector in *OBSTACKP. */
3897 num_defns_collected (struct obstack
*obstackp
)
3899 return obstack_object_size (obstackp
) / sizeof (struct ada_symbol_info
);
3902 /* Vector of ada_symbol_info structures currently collected in current
3903 vector in *OBSTACKP. If FINISH, close off the vector and return
3904 its final address. */
3906 static struct ada_symbol_info
*
3907 defns_collected (struct obstack
*obstackp
, int finish
)
3910 return obstack_finish (obstackp
);
3912 return (struct ada_symbol_info
*) obstack_base (obstackp
);
3915 /* Look, in partial_symtab PST, for symbol NAME in given namespace.
3916 Check the global symbols if GLOBAL, the static symbols if not.
3917 Do wild-card match if WILD. */
3919 static struct partial_symbol
*
3920 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3921 int global
, domain_enum
namespace, int wild
)
3923 struct partial_symbol
**start
;
3924 int name_len
= strlen (name
);
3925 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3934 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3935 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3939 for (i
= 0; i
< length
; i
+= 1)
3941 struct partial_symbol
*psym
= start
[i
];
3943 if (SYMBOL_DOMAIN (psym
) == namespace
3944 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (psym
)))
3958 int M
= (U
+ i
) >> 1;
3959 struct partial_symbol
*psym
= start
[M
];
3960 if (SYMBOL_LINKAGE_NAME (psym
)[0] < name
[0])
3962 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > name
[0])
3964 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), name
) < 0)
3975 struct partial_symbol
*psym
= start
[i
];
3977 if (SYMBOL_DOMAIN (psym
) == namespace)
3979 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
), name_len
);
3987 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4001 int M
= (U
+ i
) >> 1;
4002 struct partial_symbol
*psym
= start
[M
];
4003 if (SYMBOL_LINKAGE_NAME (psym
)[0] < '_')
4005 else if (SYMBOL_LINKAGE_NAME (psym
)[0] > '_')
4007 else if (strcmp (SYMBOL_LINKAGE_NAME (psym
), "_ada_") < 0)
4018 struct partial_symbol
*psym
= start
[i
];
4020 if (SYMBOL_DOMAIN (psym
) == namespace)
4024 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (psym
)[0];
4027 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (psym
), 5);
4029 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (psym
) + 5,
4039 && is_name_suffix (SYMBOL_LINKAGE_NAME (psym
)
4049 /* Find a symbol table containing symbol SYM or NULL if none. */
4051 static struct symtab
*
4052 symtab_for_sym (struct symbol
*sym
)
4055 struct objfile
*objfile
;
4057 struct symbol
*tmp_sym
;
4058 struct dict_iterator iter
;
4061 ALL_SYMTABS (objfile
, s
)
4063 switch (SYMBOL_CLASS (sym
))
4071 case LOC_CONST_BYTES
:
4072 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
4073 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4075 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
4076 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4082 switch (SYMBOL_CLASS (sym
))
4088 case LOC_REGPARM_ADDR
:
4093 case LOC_BASEREG_ARG
:
4095 case LOC_COMPUTED_ARG
:
4096 for (j
= FIRST_LOCAL_BLOCK
;
4097 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
4099 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
4100 ALL_BLOCK_SYMBOLS (b
, iter
, tmp_sym
) if (sym
== tmp_sym
)
4111 /* Return a minimal symbol matching NAME according to Ada decoding
4112 rules. Returns NULL if there is no such minimal symbol. Names
4113 prefixed with "standard__" are handled specially: "standard__" is
4114 first stripped off, and only static and global symbols are searched. */
4116 struct minimal_symbol
*
4117 ada_lookup_simple_minsym (const char *name
)
4119 struct objfile
*objfile
;
4120 struct minimal_symbol
*msymbol
;
4123 if (strncmp (name
, "standard__", sizeof ("standard__") - 1) == 0)
4125 name
+= sizeof ("standard__") - 1;
4129 wild_match
= (strstr (name
, "__") == NULL
);
4131 ALL_MSYMBOLS (objfile
, msymbol
)
4133 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
)
4134 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
4141 /* Return up minimal symbol for NAME, folded and encoded according to
4142 Ada conventions, or NULL if none. The last two arguments are ignored. */
4144 static struct minimal_symbol
*
4145 ada_lookup_minimal_symbol (const char *name
, const char *sfile
,
4146 struct objfile
*objf
)
4148 return ada_lookup_simple_minsym (ada_encode (name
));
4151 /* For all subprograms that statically enclose the subprogram of the
4152 selected frame, add symbols matching identifier NAME in DOMAIN
4153 and their blocks to the list of data in OBSTACKP, as for
4154 ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
4158 add_symbols_from_enclosing_procs (struct obstack
*obstackp
,
4159 const char *name
, domain_enum
namespace,
4162 #ifdef HAVE_ADD_SYMBOLS_FROM_ENCLOSING_PROCS
4163 /* Use a heuristic to find the frames of enclosing subprograms: treat the
4164 pointer-sized value at location 0 from the local-variable base of a
4165 frame as a static link, and then search up the call stack for a
4166 frame with that same local-variable base. */
4167 static struct symbol static_link_sym
;
4168 static struct symbol
*static_link
;
4169 struct value
*target_link_val
;
4171 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4172 struct frame_info
*frame
;
4174 if (!target_has_stack
)
4177 if (static_link
== NULL
)
4179 /* Initialize the local variable symbol that stands for the
4180 static link (when there is one). */
4181 static_link
= &static_link_sym
;
4182 SYMBOL_LINKAGE_NAME (static_link
) = "";
4183 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
4184 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
4185 SYMBOL_DOMAIN (static_link
) = VAR_DOMAIN
;
4186 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
4187 SYMBOL_VALUE (static_link
) =
4188 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
4191 frame
= get_selected_frame ();
4192 if (frame
== NULL
|| inside_main_func (get_frame_address_in_block (frame
)))
4195 target_link_val
= read_var_value (static_link
, frame
);
4196 while (target_link_val
!= NULL
4197 && num_defns_collected (obstackp
) == 0
4198 && frame_relative_level (frame
) <= MAX_ENCLOSING_FRAME_LEVELS
)
4200 CORE_ADDR target_link
= value_as_address (target_link_val
);
4202 frame
= get_prev_frame (frame
);
4206 if (get_frame_locals_address (frame
) == target_link
)
4208 struct block
*block
;
4212 block
= get_frame_block (frame
, 0);
4213 while (block
!= NULL
&& block_function (block
) != NULL
4214 && num_defns_collected (obstackp
) == 0)
4218 ada_add_block_symbols (obstackp
, block
, name
, namespace,
4219 NULL
, NULL
, wild_match
);
4221 block
= BLOCK_SUPERBLOCK (block
);
4226 do_cleanups (old_chain
);
4230 /* FIXME: The next two routines belong in symtab.c */
4233 restore_language (void *lang
)
4235 set_language ((enum language
) lang
);
4238 /* As for lookup_symbol, but performed as if the current language
4242 lookup_symbol_in_language (const char *name
, const struct block
*block
,
4243 domain_enum domain
, enum language lang
,
4244 int *is_a_field_of_this
, struct symtab
**symtab
)
4246 struct cleanup
*old_chain
4247 = make_cleanup (restore_language
, (void *) current_language
->la_language
);
4248 struct symbol
*result
;
4249 set_language (lang
);
4250 result
= lookup_symbol (name
, block
, domain
, is_a_field_of_this
, symtab
);
4251 do_cleanups (old_chain
);
4255 /* True if TYPE is definitely an artificial type supplied to a symbol
4256 for which no debugging information was given in the symbol file. */
4259 is_nondebugging_type (struct type
*type
)
4261 char *name
= ada_type_name (type
);
4262 return (name
!= NULL
&& strcmp (name
, "<variable, no debug info>") == 0);
4265 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
4266 duplicate other symbols in the list (The only case I know of where
4267 this happens is when object files containing stabs-in-ecoff are
4268 linked with files containing ordinary ecoff debugging symbols (or no
4269 debugging symbols)). Modifies SYMS to squeeze out deleted entries.
4270 Returns the number of items in the modified list. */
4273 remove_extra_symbols (struct ada_symbol_info
*syms
, int nsyms
)
4280 if (SYMBOL_LINKAGE_NAME (syms
[i
].sym
) != NULL
4281 && SYMBOL_CLASS (syms
[i
].sym
) == LOC_STATIC
4282 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
].sym
)))
4284 for (j
= 0; j
< nsyms
; j
+= 1)
4287 && SYMBOL_LINKAGE_NAME (syms
[j
].sym
) != NULL
4288 && strcmp (SYMBOL_LINKAGE_NAME (syms
[i
].sym
),
4289 SYMBOL_LINKAGE_NAME (syms
[j
].sym
)) == 0
4290 && SYMBOL_CLASS (syms
[i
].sym
) == SYMBOL_CLASS (syms
[j
].sym
)
4291 && SYMBOL_VALUE_ADDRESS (syms
[i
].sym
)
4292 == SYMBOL_VALUE_ADDRESS (syms
[j
].sym
))
4295 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
4296 syms
[k
- 1] = syms
[k
];
4309 /* Given a type that corresponds to a renaming entity, use the type name
4310 to extract the scope (package name or function name, fully qualified,
4311 and following the GNAT encoding convention) where this renaming has been
4312 defined. The string returned needs to be deallocated after use. */
4315 xget_renaming_scope (struct type
*renaming_type
)
4317 /* The renaming types adhere to the following convention:
4318 <scope>__<rename>___<XR extension>.
4319 So, to extract the scope, we search for the "___XR" extension,
4320 and then backtrack until we find the first "__". */
4322 const char *name
= type_name_no_tag (renaming_type
);
4323 char *suffix
= strstr (name
, "___XR");
4328 /* Now, backtrack a bit until we find the first "__". Start looking
4329 at suffix - 3, as the <rename> part is at least one character long. */
4331 for (last
= suffix
- 3; last
> name
; last
--)
4332 if (last
[0] == '_' && last
[1] == '_')
4335 /* Make a copy of scope and return it. */
4337 scope_len
= last
- name
;
4338 scope
= (char *) xmalloc ((scope_len
+ 1) * sizeof (char));
4340 strncpy (scope
, name
, scope_len
);
4341 scope
[scope_len
] = '\0';
4346 /* Return nonzero if NAME corresponds to a package name. */
4349 is_package_name (const char *name
)
4351 /* Here, We take advantage of the fact that no symbols are generated
4352 for packages, while symbols are generated for each function.
4353 So the condition for NAME represent a package becomes equivalent
4354 to NAME not existing in our list of symbols. There is only one
4355 small complication with library-level functions (see below). */
4359 /* If it is a function that has not been defined at library level,
4360 then we should be able to look it up in the symbols. */
4361 if (standard_lookup (name
, NULL
, VAR_DOMAIN
) != NULL
)
4364 /* Library-level function names start with "_ada_". See if function
4365 "_ada_" followed by NAME can be found. */
4367 /* Do a quick check that NAME does not contain "__", since library-level
4368 functions names can not contain "__" in them. */
4369 if (strstr (name
, "__") != NULL
)
4372 fun_name
= xstrprintf ("_ada_%s", name
);
4374 return (standard_lookup (fun_name
, NULL
, VAR_DOMAIN
) == NULL
);
4377 /* Return nonzero if SYM corresponds to a renaming entity that is
4378 visible from FUNCTION_NAME. */
4381 renaming_is_visible (const struct symbol
*sym
, char *function_name
)
4383 char *scope
= xget_renaming_scope (SYMBOL_TYPE (sym
));
4385 make_cleanup (xfree
, scope
);
4387 /* If the rename has been defined in a package, then it is visible. */
4388 if (is_package_name (scope
))
4391 /* Check that the rename is in the current function scope by checking
4392 that its name starts with SCOPE. */
4394 /* If the function name starts with "_ada_", it means that it is
4395 a library-level function. Strip this prefix before doing the
4396 comparison, as the encoding for the renaming does not contain
4398 if (strncmp (function_name
, "_ada_", 5) == 0)
4401 return (strncmp (function_name
, scope
, strlen (scope
)) == 0);
4404 /* Iterates over the SYMS list and remove any entry that corresponds to
4405 a renaming entity that is not visible from the function associated
4409 GNAT emits a type following a specified encoding for each renaming
4410 entity. Unfortunately, STABS currently does not support the definition
4411 of types that are local to a given lexical block, so all renamings types
4412 are emitted at library level. As a consequence, if an application
4413 contains two renaming entities using the same name, and a user tries to
4414 print the value of one of these entities, the result of the ada symbol
4415 lookup will also contain the wrong renaming type.
4417 This function partially covers for this limitation by attempting to
4418 remove from the SYMS list renaming symbols that should be visible
4419 from CURRENT_BLOCK. However, there does not seem be a 100% reliable
4420 method with the current information available. The implementation
4421 below has a couple of limitations (FIXME: brobecker-2003-05-12):
4423 - When the user tries to print a rename in a function while there
4424 is another rename entity defined in a package: Normally, the
4425 rename in the function has precedence over the rename in the
4426 package, so the latter should be removed from the list. This is
4427 currently not the case.
4429 - This function will incorrectly remove valid renames if
4430 the CURRENT_BLOCK corresponds to a function which symbol name
4431 has been changed by an "Export" pragma. As a consequence,
4432 the user will be unable to print such rename entities. */
4435 remove_out_of_scope_renamings (struct ada_symbol_info
*syms
,
4436 int nsyms
, struct block
*current_block
)
4438 struct symbol
*current_function
;
4439 char *current_function_name
;
4442 /* Extract the function name associated to CURRENT_BLOCK.
4443 Abort if unable to do so. */
4445 if (current_block
== NULL
)
4448 current_function
= block_function (current_block
);
4449 if (current_function
== NULL
)
4452 current_function_name
= SYMBOL_LINKAGE_NAME (current_function
);
4453 if (current_function_name
== NULL
)
4456 /* Check each of the symbols, and remove it from the list if it is
4457 a type corresponding to a renaming that is out of the scope of
4458 the current block. */
4463 if (ada_is_object_renaming (syms
[i
].sym
)
4464 && !renaming_is_visible (syms
[i
].sym
, current_function_name
))
4467 for (j
= i
+ 1; j
< nsyms
; j
++)
4468 syms
[j
- 1] = syms
[j
];
4478 /* Find symbols in DOMAIN matching NAME0, in BLOCK0 and enclosing
4479 scope and in global scopes, returning the number of matches. Sets
4480 *RESULTS to point to a vector of (SYM,BLOCK,SYMTAB) triples,
4481 indicating the symbols found and the blocks and symbol tables (if
4482 any) in which they were found. This vector are transient---good only to
4483 the next call of ada_lookup_symbol_list. Any non-function/non-enumeral
4484 symbol match within the nest of blocks whose innermost member is BLOCK0,
4485 is the one match returned (no other matches in that or
4486 enclosing blocks is returned). If there are any matches in or
4487 surrounding BLOCK0, then these alone are returned. Otherwise, the
4488 search extends to global and file-scope (static) symbol tables.
4489 Names prefixed with "standard__" are handled specially: "standard__"
4490 is first stripped off, and only static and global symbols are searched. */
4493 ada_lookup_symbol_list (const char *name0
, const struct block
*block0
,
4494 domain_enum
namespace,
4495 struct ada_symbol_info
**results
)
4499 struct partial_symtab
*ps
;
4500 struct blockvector
*bv
;
4501 struct objfile
*objfile
;
4502 struct block
*block
;
4504 struct minimal_symbol
*msymbol
;
4510 obstack_free (&symbol_list_obstack
, NULL
);
4511 obstack_init (&symbol_list_obstack
);
4515 /* Search specified block and its superiors. */
4517 wild_match
= (strstr (name0
, "__") == NULL
);
4519 block
= (struct block
*) block0
; /* FIXME: No cast ought to be
4520 needed, but adding const will
4521 have a cascade effect. */
4522 if (strncmp (name0
, "standard__", sizeof ("standard__") - 1) == 0)
4526 name
= name0
+ sizeof ("standard__") - 1;
4530 while (block
!= NULL
)
4533 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4534 namespace, NULL
, NULL
, wild_match
);
4536 /* If we found a non-function match, assume that's the one. */
4537 if (is_nonfunction (defns_collected (&symbol_list_obstack
, 0),
4538 num_defns_collected (&symbol_list_obstack
)))
4541 block
= BLOCK_SUPERBLOCK (block
);
4544 /* If no luck so far, try to find NAME as a local symbol in some lexically
4545 enclosing subprogram. */
4546 if (num_defns_collected (&symbol_list_obstack
) == 0 && block_depth
> 2)
4547 add_symbols_from_enclosing_procs (&symbol_list_obstack
,
4548 name
, namespace, wild_match
);
4550 /* If we found ANY matches among non-global symbols, we're done. */
4552 if (num_defns_collected (&symbol_list_obstack
) > 0)
4556 if (lookup_cached_symbol (name0
, namespace, &sym
, &block
, &s
))
4559 add_defn_to_vec (&symbol_list_obstack
, sym
, block
, s
);
4563 /* Now add symbols from all global blocks: symbol tables, minimal symbol
4564 tables, and psymtab's. */
4566 ALL_SYMTABS (objfile
, s
)
4571 bv
= BLOCKVECTOR (s
);
4572 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4573 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4574 objfile
, s
, wild_match
);
4577 if (namespace == VAR_DOMAIN
)
4579 ALL_MSYMBOLS (objfile
, msymbol
)
4581 if (ada_match_name (SYMBOL_LINKAGE_NAME (msymbol
), name
, wild_match
))
4583 switch (MSYMBOL_TYPE (msymbol
))
4585 case mst_solib_trampoline
:
4588 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
4591 int ndefns0
= num_defns_collected (&symbol_list_obstack
);
4593 bv
= BLOCKVECTOR (s
);
4594 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4595 ada_add_block_symbols (&symbol_list_obstack
, block
,
4596 SYMBOL_LINKAGE_NAME (msymbol
),
4597 namespace, objfile
, s
, wild_match
);
4599 if (num_defns_collected (&symbol_list_obstack
) == ndefns0
)
4601 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4602 ada_add_block_symbols (&symbol_list_obstack
, block
,
4603 SYMBOL_LINKAGE_NAME (msymbol
),
4604 namespace, objfile
, s
,
4613 ALL_PSYMTABS (objfile
, ps
)
4617 && ada_lookup_partial_symbol (ps
, name
, 1, namespace, wild_match
))
4619 s
= PSYMTAB_TO_SYMTAB (ps
);
4622 bv
= BLOCKVECTOR (s
);
4623 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4624 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4625 namespace, objfile
, s
, wild_match
);
4629 /* Now add symbols from all per-file blocks if we've gotten no hits
4630 (Not strictly correct, but perhaps better than an error).
4631 Do the symtabs first, then check the psymtabs. */
4633 if (num_defns_collected (&symbol_list_obstack
) == 0)
4636 ALL_SYMTABS (objfile
, s
)
4641 bv
= BLOCKVECTOR (s
);
4642 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4643 ada_add_block_symbols (&symbol_list_obstack
, block
, name
, namespace,
4644 objfile
, s
, wild_match
);
4647 ALL_PSYMTABS (objfile
, ps
)
4651 && ada_lookup_partial_symbol (ps
, name
, 0, namespace, wild_match
))
4653 s
= PSYMTAB_TO_SYMTAB (ps
);
4654 bv
= BLOCKVECTOR (s
);
4657 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
4658 ada_add_block_symbols (&symbol_list_obstack
, block
, name
,
4659 namespace, objfile
, s
, wild_match
);
4665 ndefns
= num_defns_collected (&symbol_list_obstack
);
4666 *results
= defns_collected (&symbol_list_obstack
, 1);
4668 ndefns
= remove_extra_symbols (*results
, ndefns
);
4671 cache_symbol (name0
, namespace, NULL
, NULL
, NULL
);
4673 if (ndefns
== 1 && cacheIfUnique
)
4674 cache_symbol (name0
, namespace, (*results
)[0].sym
, (*results
)[0].block
,
4675 (*results
)[0].symtab
);
4677 ndefns
= remove_out_of_scope_renamings (*results
, ndefns
,
4678 (struct block
*) block0
);
4683 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
4684 scope and in global scopes, or NULL if none. NAME is folded and
4685 encoded first. Otherwise, the result is as for ada_lookup_symbol_list,
4686 but is disambiguated by user query if needed. *IS_A_FIELD_OF_THIS is
4687 set to 0 and *SYMTAB is set to the symbol table in which the symbol
4688 was found (in both cases, these assignments occur only if the
4689 pointers are non-null). */
4693 ada_lookup_symbol (const char *name
, const struct block
*block0
,
4694 domain_enum
namespace, int *is_a_field_of_this
,
4695 struct symtab
**symtab
)
4697 struct ada_symbol_info
*candidates
;
4700 n_candidates
= ada_lookup_symbol_list (ada_encode (ada_fold_name (name
)),
4701 block0
, namespace, &candidates
);
4703 if (n_candidates
== 0)
4705 else if (n_candidates
!= 1)
4706 user_select_syms (candidates
, n_candidates
, 1);
4708 if (is_a_field_of_this
!= NULL
)
4709 *is_a_field_of_this
= 0;
4713 *symtab
= candidates
[0].symtab
;
4714 if (*symtab
== NULL
&& candidates
[0].block
!= NULL
)
4716 struct objfile
*objfile
;
4719 struct blockvector
*bv
;
4721 /* Search the list of symtabs for one which contains the
4722 address of the start of this block. */
4723 ALL_SYMTABS (objfile
, s
)
4725 bv
= BLOCKVECTOR (s
);
4726 b
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
4727 if (BLOCK_START (b
) <= BLOCK_START (candidates
[0].block
)
4728 && BLOCK_END (b
) > BLOCK_START (candidates
[0].block
))
4731 return fixup_symbol_section (candidates
[0].sym
, objfile
);
4733 return fixup_symbol_section (candidates
[0].sym
, NULL
);
4737 return candidates
[0].sym
;
4740 static struct symbol
*
4741 ada_lookup_symbol_nonlocal (const char *name
,
4742 const char *linkage_name
,
4743 const struct block
*block
,
4744 const domain_enum domain
, struct symtab
**symtab
)
4746 if (linkage_name
== NULL
)
4747 linkage_name
= name
;
4748 return ada_lookup_symbol (linkage_name
, block_static_block (block
), domain
,
4753 /* True iff STR is a possible encoded suffix of a normal Ada name
4754 that is to be ignored for matching purposes. Suffixes of parallel
4755 names (e.g., XVE) are not included here. Currently, the possible suffixes
4756 are given by either of the regular expression:
4758 (__[0-9]+)?\.[0-9]+ [nested subprogram suffix, on platforms such
4760 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4761 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(LJM|X([FDBUP].*|R[^T]?)))?$
4765 is_name_suffix (const char *str
)
4768 const char *matching
;
4769 const int len
= strlen (str
);
4771 /* (__[0-9]+)?\.[0-9]+ */
4773 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4776 while (isdigit (matching
[0]))
4778 if (matching
[0] == '\0')
4782 if (matching
[0] == '.')
4785 while (isdigit (matching
[0]))
4787 if (matching
[0] == '\0')
4792 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4795 while (isdigit (matching
[0]))
4797 if (matching
[0] == '\0')
4801 /* ??? We should not modify STR directly, as we are doing below. This
4802 is fine in this case, but may become problematic later if we find
4803 that this alternative did not work, and want to try matching
4804 another one from the begining of STR. Since we modified it, we
4805 won't be able to find the begining of the string anymore! */
4809 while (str
[0] != '_' && str
[0] != '\0')
4811 if (str
[0] != 'n' && str
[0] != 'b')
4816 if (str
[0] == '\000')
4820 if (str
[1] != '_' || str
[2] == '\000')
4824 if (strcmp (str
+ 3, "LJM") == 0)
4828 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4829 || str
[4] == 'U' || str
[4] == 'P')
4831 if (str
[4] == 'R' && str
[5] != 'T')
4835 if (!isdigit (str
[2]))
4837 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4838 if (!isdigit (str
[k
]) && str
[k
] != '_')
4842 if (str
[0] == '$' && isdigit (str
[1]))
4844 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4845 if (!isdigit (str
[k
]) && str
[k
] != '_')
4852 /* Return nonzero if the given string starts with a dot ('.')
4853 followed by zero or more digits.
4855 Note: brobecker/2003-11-10: A forward declaration has not been
4856 added at the begining of this file yet, because this function
4857 is only used to work around a problem found during wild matching
4858 when trying to match minimal symbol names against symbol names
4859 obtained from dwarf-2 data. This function is therefore currently
4860 only used in wild_match() and is likely to be deleted when the
4861 problem in dwarf-2 is fixed. */
4864 is_dot_digits_suffix (const char *str
)
4870 while (isdigit (str
[0]))
4872 return (str
[0] == '\0');
4875 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4876 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4877 informational suffixes of NAME (i.e., for which is_name_suffix is
4881 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4887 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4888 stored in the symbol table for nested function names is sometimes
4889 different from the name of the associated entity stored in
4890 the dwarf-2 data: This is the case for nested subprograms, where
4891 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4892 while the symbol name from the dwarf-2 data does not.
4894 Although the DWARF-2 standard documents that entity names stored
4895 in the dwarf-2 data should be identical to the name as seen in
4896 the source code, GNAT takes a different approach as we already use
4897 a special encoding mechanism to convey the information so that
4898 a C debugger can still use the information generated to debug
4899 Ada programs. A corollary is that the symbol names in the dwarf-2
4900 data should match the names found in the symbol table. I therefore
4901 consider this issue as a compiler defect.
4903 Until the compiler is properly fixed, we work-around the problem
4904 by ignoring such suffixes during the match. We do so by making
4905 a copy of PATN0 and NAME0, and then by stripping such a suffix
4906 if present. We then perform the match on the resulting strings. */
4909 name_len
= strlen (name0
);
4911 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4912 strcpy (name
, name0
);
4913 dot
= strrchr (name
, '.');
4914 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4917 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4918 strncpy (patn
, patn0
, patn_len
);
4919 patn
[patn_len
] = '\0';
4920 dot
= strrchr (patn
, '.');
4921 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4924 patn_len
= dot
- patn
;
4928 /* Now perform the wild match. */
4930 name_len
= strlen (name
);
4931 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4932 && strncmp (patn
, name
+ 5, patn_len
) == 0
4933 && is_name_suffix (name
+ patn_len
+ 5))
4936 while (name_len
>= patn_len
)
4938 if (strncmp (patn
, name
, patn_len
) == 0
4939 && is_name_suffix (name
+ patn_len
))
4947 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4952 if (!islower (name
[2]))
4959 if (!islower (name
[1]))
4970 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4971 vector *defn_symbols, updating the list of symbols in OBSTACKP
4972 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4973 OBJFILE is the section containing BLOCK.
4974 SYMTAB is recorded with each symbol added. */
4977 ada_add_block_symbols (struct obstack
*obstackp
,
4978 struct block
*block
, const char *name
,
4979 domain_enum domain
, struct objfile
*objfile
,
4980 struct symtab
*symtab
, int wild
)
4982 struct dict_iterator iter
;
4983 int name_len
= strlen (name
);
4984 /* A matching argument symbol, if any. */
4985 struct symbol
*arg_sym
;
4986 /* Set true when we find a matching non-argument symbol. */
4995 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4997 if (SYMBOL_DOMAIN (sym
) == domain
4998 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
5000 switch (SYMBOL_CLASS (sym
))
5006 case LOC_REGPARM_ADDR
:
5007 case LOC_BASEREG_ARG
:
5008 case LOC_COMPUTED_ARG
:
5011 case LOC_UNRESOLVED
:
5015 add_defn_to_vec (obstackp
,
5016 fixup_symbol_section (sym
, objfile
),
5025 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5027 if (SYMBOL_DOMAIN (sym
) == domain
)
5029 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5031 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5033 switch (SYMBOL_CLASS (sym
))
5039 case LOC_REGPARM_ADDR
:
5040 case LOC_BASEREG_ARG
:
5041 case LOC_COMPUTED_ARG
:
5044 case LOC_UNRESOLVED
:
5048 add_defn_to_vec (obstackp
,
5049 fixup_symbol_section (sym
, objfile
),
5058 if (!found_sym
&& arg_sym
!= NULL
)
5060 add_defn_to_vec (obstackp
,
5061 fixup_symbol_section (arg_sym
, objfile
),
5070 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5072 if (SYMBOL_DOMAIN (sym
) == domain
)
5076 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5079 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5081 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5086 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5088 switch (SYMBOL_CLASS (sym
))
5094 case LOC_REGPARM_ADDR
:
5095 case LOC_BASEREG_ARG
:
5096 case LOC_COMPUTED_ARG
:
5099 case LOC_UNRESOLVED
:
5103 add_defn_to_vec (obstackp
,
5104 fixup_symbol_section (sym
, objfile
),
5113 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5114 They aren't parameters, right? */
5115 if (!found_sym
&& arg_sym
!= NULL
)
5117 add_defn_to_vec (obstackp
,
5118 fixup_symbol_section (arg_sym
, objfile
),
5126 /* Symbol Completion */
5128 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5129 name in a form that's appropriate for the completion. The result
5130 does not need to be deallocated, but is only good until the next call.
5132 TEXT_LEN is equal to the length of TEXT.
5133 Perform a wild match if WILD_MATCH is set.
5134 ENCODED should be set if TEXT represents the start of a symbol name
5135 in its encoded form. */
5138 symbol_completion_match (const char *sym_name
,
5139 const char *text
, int text_len
,
5140 int wild_match
, int encoded
)
5143 const int verbatim_match
= (text
[0] == '<');
5148 /* Strip the leading angle bracket. */
5153 /* First, test against the fully qualified name of the symbol. */
5155 if (strncmp (sym_name
, text
, text_len
) == 0)
5158 if (match
&& !encoded
)
5160 /* One needed check before declaring a positive match is to verify
5161 that iff we are doing a verbatim match, the decoded version
5162 of the symbol name starts with '<'. Otherwise, this symbol name
5163 is not a suitable completion. */
5164 const char *sym_name_copy
= sym_name
;
5165 int has_angle_bracket
;
5167 sym_name
= ada_decode (sym_name
);
5168 has_angle_bracket
= (sym_name
[0] == '<');
5169 match
= (has_angle_bracket
== verbatim_match
);
5170 sym_name
= sym_name_copy
;
5173 if (match
&& !verbatim_match
)
5175 /* When doing non-verbatim match, another check that needs to
5176 be done is to verify that the potentially matching symbol name
5177 does not include capital letters, because the ada-mode would
5178 not be able to understand these symbol names without the
5179 angle bracket notation. */
5182 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5187 /* Second: Try wild matching... */
5189 if (!match
&& wild_match
)
5191 /* Since we are doing wild matching, this means that TEXT
5192 may represent an unqualified symbol name. We therefore must
5193 also compare TEXT against the unqualified name of the symbol. */
5194 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5196 if (strncmp (sym_name
, text
, text_len
) == 0)
5200 /* Finally: If we found a mach, prepare the result to return. */
5206 sym_name
= add_angle_brackets (sym_name
);
5209 sym_name
= ada_decode (sym_name
);
5214 /* A companion function to ada_make_symbol_completion_list().
5215 Check if SYM_NAME represents a symbol which name would be suitable
5216 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5217 it is appended at the end of the given string vector SV.
5219 ORIG_TEXT is the string original string from the user command
5220 that needs to be completed. WORD is the entire command on which
5221 completion should be performed. These two parameters are used to
5222 determine which part of the symbol name should be added to the
5224 if WILD_MATCH is set, then wild matching is performed.
5225 ENCODED should be set if TEXT represents a symbol name in its
5226 encoded formed (in which case the completion should also be
5230 symbol_completion_add (struct string_vector
*sv
,
5231 const char *sym_name
,
5232 const char *text
, int text_len
,
5233 const char *orig_text
, const char *word
,
5234 int wild_match
, int encoded
)
5236 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5237 wild_match
, encoded
);
5243 /* We found a match, so add the appropriate completion to the given
5246 if (word
== orig_text
)
5248 completion
= xmalloc (strlen (match
) + 5);
5249 strcpy (completion
, match
);
5251 else if (word
> orig_text
)
5253 /* Return some portion of sym_name. */
5254 completion
= xmalloc (strlen (match
) + 5);
5255 strcpy (completion
, match
+ (word
- orig_text
));
5259 /* Return some of ORIG_TEXT plus sym_name. */
5260 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5261 strncpy (completion
, word
, orig_text
- word
);
5262 completion
[orig_text
- word
] = '\0';
5263 strcat (completion
, match
);
5266 string_vector_append (sv
, completion
);
5269 /* Return a list of possible symbol names completing TEXT0. The list
5270 is NULL terminated. WORD is the entire command on which completion
5274 ada_make_symbol_completion_list (const char *text0
, const char *word
)
5276 /* Note: This function is almost a copy of make_symbol_completion_list(),
5277 except it has been adapted for Ada. It is somewhat of a shame to
5278 duplicate so much code, but we don't really have the infrastructure
5279 yet to develop a language-aware version of he symbol completer... */
5284 struct string_vector result
= xnew_string_vector (128);
5287 struct partial_symtab
*ps
;
5288 struct minimal_symbol
*msymbol
;
5289 struct objfile
*objfile
;
5290 struct block
*b
, *surrounding_static_block
= 0;
5292 struct dict_iterator iter
;
5294 if (text0
[0] == '<')
5296 text
= xstrdup (text0
);
5297 make_cleanup (xfree
, text
);
5298 text_len
= strlen (text
);
5304 text
= xstrdup (ada_encode (text0
));
5305 make_cleanup (xfree
, text
);
5306 text_len
= strlen (text
);
5307 for (i
= 0; i
< text_len
; i
++)
5308 text
[i
] = tolower (text
[i
]);
5310 /* FIXME: brobecker/2003-09-17: When we get rid of ADA_RETAIN_DOTS,
5311 we can restrict the wild_match check to searching "__" only. */
5312 wild_match
= (strstr (text0
, "__") == NULL
5313 && strchr (text0
, '.') == NULL
);
5314 encoded
= (strstr (text0
, "__") != NULL
);
5317 /* First, look at the partial symtab symbols. */
5318 ALL_PSYMTABS (objfile
, ps
)
5320 struct partial_symbol
**psym
;
5322 /* If the psymtab's been read in we'll get it when we search
5323 through the blockvector. */
5327 for (psym
= objfile
->global_psymbols
.list
+ ps
->globals_offset
;
5328 psym
< (objfile
->global_psymbols
.list
+ ps
->globals_offset
5329 + ps
->n_global_syms
); psym
++)
5332 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (*psym
),
5333 text
, text_len
, text0
, word
,
5334 wild_match
, encoded
);
5337 for (psym
= objfile
->static_psymbols
.list
+ ps
->statics_offset
;
5338 psym
< (objfile
->static_psymbols
.list
+ ps
->statics_offset
5339 + ps
->n_static_syms
); psym
++)
5342 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (*psym
),
5343 text
, text_len
, text0
, word
,
5344 wild_match
, encoded
);
5348 /* At this point scan through the misc symbol vectors and add each
5349 symbol you find to the list. Eventually we want to ignore
5350 anything that isn't a text symbol (everything else will be
5351 handled by the psymtab code above). */
5353 ALL_MSYMBOLS (objfile
, msymbol
)
5356 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (msymbol
),
5357 text
, text_len
, text0
, word
, wild_match
, encoded
);
5360 /* Search upwards from currently selected frame (so that we can
5361 complete on local vars. */
5363 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5365 if (!BLOCK_SUPERBLOCK (b
))
5366 surrounding_static_block
= b
; /* For elmin of dups */
5368 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5370 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5371 text
, text_len
, text0
, word
,
5372 wild_match
, encoded
);
5376 /* Go through the symtabs and check the externs and statics for
5377 symbols which match. */
5379 ALL_SYMTABS (objfile
, s
)
5382 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5383 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5385 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5386 text
, text_len
, text0
, word
,
5387 wild_match
, encoded
);
5391 ALL_SYMTABS (objfile
, s
)
5394 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5395 /* Don't do this block twice. */
5396 if (b
== surrounding_static_block
)
5398 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5400 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5401 text
, text_len
, text0
, word
,
5402 wild_match
, encoded
);
5406 /* Append the closing NULL entry. */
5407 string_vector_append (&result
, NULL
);
5409 return (result
.array
);
5412 #endif /* GNAT_GDB */
5415 /* Breakpoint-related */
5417 /* Assuming that LINE is pointing at the beginning of an argument to
5418 'break', return a pointer to the delimiter for the initial segment
5419 of that name. This is the first ':', ' ', or end of LINE. */
5422 ada_start_decode_line_1 (char *line
)
5424 /* NOTE: strpbrk would be more elegant, but I am reluctant to be
5425 the first to use such a library function in GDB code. */
5427 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
5432 /* *SPEC points to a function and line number spec (as in a break
5433 command), following any initial file name specification.
5435 Return all symbol table/line specfications (sals) consistent with the
5436 information in *SPEC and FILE_TABLE in the following sense:
5437 + FILE_TABLE is null, or the sal refers to a line in the file
5438 named by FILE_TABLE.
5439 + If *SPEC points to an argument with a trailing ':LINENUM',
5440 then the sal refers to that line (or one following it as closely as
5442 + If *SPEC does not start with '*', the sal is in a function with
5445 Returns with 0 elements if no matching non-minimal symbols found.
5447 If *SPEC begins with a function name of the form <NAME>, then NAME
5448 is taken as a literal name; otherwise the function name is subject
5449 to the usual encoding.
5451 *SPEC is updated to point after the function/line number specification.
5453 FUNFIRSTLINE is non-zero if we desire the first line of real code
5456 If CANONICAL is non-NULL, and if any of the sals require a
5457 'canonical line spec', then *CANONICAL is set to point to an array
5458 of strings, corresponding to and equal in length to the returned
5459 list of sals, such that (*CANONICAL)[i] is non-null and contains a
5460 canonical line spec for the ith returned sal, if needed. If no
5461 canonical line specs are required and CANONICAL is non-null,
5462 *CANONICAL is set to NULL.
5464 A 'canonical line spec' is simply a name (in the format of the
5465 breakpoint command) that uniquely identifies a breakpoint position,
5466 with no further contextual information or user selection. It is
5467 needed whenever the file name, function name, and line number
5468 information supplied is insufficient for this unique
5469 identification. Currently overloaded functions, the name '*',
5470 or static functions without a filename yield a canonical line spec.
5471 The array and the line spec strings are allocated on the heap; it
5472 is the caller's responsibility to free them. */
5474 struct symtabs_and_lines
5475 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
5476 int funfirstline
, char ***canonical
)
5478 struct ada_symbol_info
*symbols
;
5479 const struct block
*block
;
5480 int n_matches
, i
, line_num
;
5481 struct symtabs_and_lines selected
;
5482 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
5488 char *unquoted_name
;
5490 if (file_table
== NULL
)
5491 block
= block_static_block (get_selected_block (0));
5493 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
5495 if (canonical
!= NULL
)
5496 *canonical
= (char **) NULL
;
5498 is_quoted
= (**spec
&& strchr (get_gdb_completer_quote_characters (),
5507 *spec
= skip_quoted (*spec
);
5508 while (**spec
!= '\000'
5509 && !strchr (ada_completer_word_break_characters
, **spec
))
5515 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
5517 line_num
= strtol (*spec
+ 1, spec
, 10);
5518 while (**spec
== ' ' || **spec
== '\t')
5525 error ("Wild-card function with no line number or file name.");
5527 return ada_sals_for_line (file_table
->filename
, line_num
,
5528 funfirstline
, canonical
, 0);
5531 if (name
[0] == '\'')
5539 unquoted_name
= (char *) alloca (len
- 1);
5540 memcpy (unquoted_name
, name
+ 1, len
- 2);
5541 unquoted_name
[len
- 2] = '\000';
5546 unquoted_name
= (char *) alloca (len
+ 1);
5547 memcpy (unquoted_name
, name
, len
);
5548 unquoted_name
[len
] = '\000';
5549 lower_name
= (char *) alloca (len
+ 1);
5550 for (i
= 0; i
< len
; i
+= 1)
5551 lower_name
[i
] = tolower (name
[i
]);
5552 lower_name
[len
] = '\000';
5556 if (lower_name
!= NULL
)
5557 n_matches
= ada_lookup_symbol_list (ada_encode (lower_name
), block
,
5558 VAR_DOMAIN
, &symbols
);
5560 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
5561 VAR_DOMAIN
, &symbols
);
5562 if (n_matches
== 0 && line_num
>= 0)
5563 error ("No line number information found for %s.", unquoted_name
);
5564 else if (n_matches
== 0)
5566 #ifdef HPPA_COMPILER_BUG
5567 /* FIXME: See comment in symtab.c::decode_line_1 */
5569 volatile struct symtab_and_line val
;
5570 #define volatile /*nothing */
5572 struct symtab_and_line val
;
5574 struct minimal_symbol
*msymbol
;
5579 if (lower_name
!= NULL
)
5580 msymbol
= ada_lookup_simple_minsym (ada_encode (lower_name
));
5581 if (msymbol
== NULL
)
5582 msymbol
= ada_lookup_simple_minsym (unquoted_name
);
5583 if (msymbol
!= NULL
)
5585 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
5586 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
5589 val
.pc
+= DEPRECATED_FUNCTION_START_OFFSET
;
5590 SKIP_PROLOGUE (val
.pc
);
5592 selected
.sals
= (struct symtab_and_line
*)
5593 xmalloc (sizeof (struct symtab_and_line
));
5594 selected
.sals
[0] = val
;
5599 if (!have_full_symbols ()
5600 && !have_partial_symbols () && !have_minimal_symbols ())
5601 error ("No symbol table is loaded. Use the \"file\" command.");
5603 error ("Function \"%s\" not defined.", unquoted_name
);
5604 return selected
; /* for lint */
5609 struct symtabs_and_lines best_sal
=
5610 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
5611 symbols
, n_matches
);
5613 adjust_pc_past_prologue (&best_sal
.sals
[0].pc
);
5618 selected
.nelts
= user_select_syms (symbols
, n_matches
, n_matches
);
5621 selected
.sals
= (struct symtab_and_line
*)
5622 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
5623 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
5624 make_cleanup (xfree
, selected
.sals
);
5627 while (i
< selected
.nelts
)
5629 if (SYMBOL_CLASS (symbols
[i
].sym
) == LOC_BLOCK
)
5631 = find_function_start_sal (symbols
[i
].sym
, funfirstline
);
5632 else if (SYMBOL_LINE (symbols
[i
].sym
) != 0)
5634 selected
.sals
[i
].symtab
=
5636 ? symbols
[i
].symtab
: symtab_for_sym (symbols
[i
].sym
);
5637 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
].sym
);
5639 else if (line_num
>= 0)
5641 /* Ignore this choice */
5642 symbols
[i
] = symbols
[selected
.nelts
- 1];
5643 selected
.nelts
-= 1;
5647 error ("Line number not known for symbol \"%s\"", unquoted_name
);
5651 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
5653 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
5654 for (i
= 0; i
< selected
.nelts
; i
+= 1)
5656 extended_canonical_line_spec (selected
.sals
[i
],
5657 SYMBOL_PRINT_NAME (symbols
[i
].sym
));
5660 discard_cleanups (old_chain
);
5664 /* The (single) sal corresponding to line LINE_NUM in a symbol table
5665 with file name FILENAME that occurs in one of the functions listed
5666 in the symbol fields of SYMBOLS[0 .. NSYMS-1]. */
5668 static struct symtabs_and_lines
5669 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
5670 struct ada_symbol_info
*symbols
, int nsyms
)
5672 struct symtabs_and_lines sals
;
5673 int best_index
, best
;
5674 struct linetable
*best_linetable
;
5675 struct objfile
*objfile
;
5677 struct symtab
*best_symtab
;
5679 read_all_symtabs (filename
);
5682 best_linetable
= NULL
;
5685 ALL_SYMTABS (objfile
, s
)
5687 struct linetable
*l
;
5692 if (strcmp (filename
, s
->filename
) != 0)
5695 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
5705 if (best
== 0 || l
->item
[ind
].line
< best
)
5707 best
= l
->item
[ind
].line
;
5716 error ("Line number not found in designated function.");
5721 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
5723 init_sal (&sals
.sals
[0]);
5725 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
5726 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
5727 sals
.sals
[0].symtab
= best_symtab
;
5732 /* Return the index in LINETABLE of the best match for LINE_NUM whose
5733 pc falls within one of the functions denoted by the symbol fields
5734 of SYMBOLS[0..NSYMS-1]. Set *EXACTP to 1 if the match is exact,
5738 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
5739 struct ada_symbol_info
*symbols
, int nsyms
,
5742 int i
, len
, best_index
, best
;
5744 if (line_num
<= 0 || linetable
== NULL
)
5747 len
= linetable
->nitems
;
5748 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
5751 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5753 for (k
= 0; k
< nsyms
; k
+= 1)
5755 if (symbols
[k
].sym
!= NULL
5756 && SYMBOL_CLASS (symbols
[k
].sym
) == LOC_BLOCK
5757 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
].sym
))
5758 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
].sym
)))
5765 if (item
->line
== line_num
)
5771 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
5782 /* Find the smallest k >= LINE_NUM such that k is a line number in
5783 LINETABLE, and k falls strictly within a named function that begins at
5784 or before LINE_NUM. Return -1 if there is no such k. */
5787 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
5791 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
5793 len
= linetable
->nitems
;
5799 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5801 if (item
->line
>= line_num
&& item
->line
< best
)
5804 CORE_ADDR start
, end
;
5807 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
5809 if (func_name
!= NULL
&& item
->pc
< end
)
5811 if (item
->line
== line_num
)
5815 struct symbol
*sym
=
5816 standard_lookup (func_name
, NULL
, VAR_DOMAIN
);
5817 if (is_plausible_func_for_line (sym
, line_num
))
5823 while (i
< len
&& linetable
->item
[i
].pc
< end
);
5833 return (best
== INT_MAX
) ? -1 : best
;
5837 /* Return the next higher index, k, into LINETABLE such that k > IND,
5838 entry k in LINETABLE has a line number equal to LINE_NUM, k
5839 corresponds to a PC that is in a function different from that
5840 corresponding to IND, and falls strictly within a named function
5841 that begins at a line at or preceding STARTING_LINE.
5842 Return -1 if there is no such k.
5843 IND == -1 corresponds to no function. */
5846 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
5847 int starting_line
, int ind
)
5851 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
5853 len
= linetable
->nitems
;
5857 CORE_ADDR start
, end
;
5859 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
5860 (char **) NULL
, &start
, &end
))
5862 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
5874 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5876 if (item
->line
>= line_num
)
5879 CORE_ADDR start
, end
;
5882 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
5884 if (func_name
!= NULL
&& item
->pc
< end
)
5886 if (item
->line
== line_num
)
5888 struct symbol
*sym
=
5889 standard_lookup (func_name
, NULL
, VAR_DOMAIN
);
5890 if (is_plausible_func_for_line (sym
, starting_line
))
5894 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
5906 /* True iff function symbol SYM starts somewhere at or before line #
5910 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
5912 struct symtab_and_line start_sal
;
5917 start_sal
= find_function_start_sal (sym
, 0);
5919 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
5922 /* Read in all symbol tables corresponding to partial symbol tables
5923 with file name FILENAME. */
5926 read_all_symtabs (const char *filename
)
5928 struct partial_symtab
*ps
;
5929 struct objfile
*objfile
;
5931 ALL_PSYMTABS (objfile
, ps
)
5935 if (strcmp (filename
, ps
->filename
) == 0)
5936 PSYMTAB_TO_SYMTAB (ps
);
5940 /* All sals corresponding to line LINE_NUM in a symbol table from file
5941 FILENAME, as filtered by the user. Filter out any lines that
5942 reside in functions with "suppressed" names (not corresponding to
5943 explicit Ada functions), if there is at least one in a function
5944 with a non-suppressed name. If CANONICAL is not null, set
5945 it to a corresponding array of canonical line specs.
5946 If ONE_LOCATION_ONLY is set and several matches are found for
5947 the given location, then automatically select the first match found
5948 instead of asking the user which instance should be returned. */
5950 struct symtabs_and_lines
5951 ada_sals_for_line (const char *filename
, int line_num
,
5952 int funfirstline
, char ***canonical
, int one_location_only
)
5954 struct symtabs_and_lines result
;
5955 struct objfile
*objfile
;
5957 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
5960 read_all_symtabs (filename
);
5963 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
5966 make_cleanup (free_current_contents
, &result
.sals
);
5968 ALL_SYMTABS (objfile
, s
)
5970 int ind
, target_line_num
;
5974 if (strcmp (s
->filename
, filename
) != 0)
5978 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
5979 if (target_line_num
== -1)
5986 find_next_line_in_linetable (LINETABLE (s
),
5987 target_line_num
, line_num
, ind
);
5992 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
5993 init_sal (&result
.sals
[result
.nelts
]);
5994 result
.sals
[result
.nelts
].line
= line_num
;
5995 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
5996 result
.sals
[result
.nelts
].symtab
= s
;
5999 adjust_pc_past_prologue (&result
.sals
[result
.nelts
].pc
);
6005 if (canonical
!= NULL
|| result
.nelts
> 1)
6008 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
6009 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
6010 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
6012 for (k
= 0; k
< result
.nelts
; k
+= 1)
6014 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
6015 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
6016 if (func_names
[k
] == NULL
)
6017 error ("Could not find function for one or more breakpoints.");
6020 /* Remove suppressed names, unless all are suppressed. */
6021 for (j
= 0; j
< result
.nelts
; j
+= 1)
6022 if (!is_suppressed_name (func_names
[j
]))
6024 /* At least one name is unsuppressed, so remove all
6025 suppressed names. */
6026 for (k
= n
= 0; k
< result
.nelts
; k
+= 1)
6027 if (!is_suppressed_name (func_names
[k
]))
6029 func_names
[n
] = func_names
[k
];
6030 result
.sals
[n
] = result
.sals
[k
];
6037 if (result
.nelts
> 1)
6039 if (one_location_only
)
6041 /* Automatically select the first of all possible choices. */
6047 printf_unfiltered ("[0] cancel\n");
6048 if (result
.nelts
> 1)
6049 printf_unfiltered ("[1] all\n");
6050 for (k
= 0; k
< result
.nelts
; k
+= 1)
6051 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
6052 ada_decode (func_names
[k
]));
6054 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
6055 result
.nelts
> 1, "instance-choice");
6058 for (k
= 0; k
< n
; k
+= 1)
6060 result
.sals
[k
] = result
.sals
[choices
[k
]];
6061 func_names
[k
] = func_names
[choices
[k
]];
6066 if (canonical
!= NULL
&& result
.nelts
== 0)
6068 else if (canonical
!= NULL
)
6070 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
6071 make_cleanup (xfree
, *canonical
);
6072 for (k
= 0; k
< result
.nelts
; k
+= 1)
6075 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
6076 if ((*canonical
)[k
] == NULL
)
6077 error ("Could not locate one or more breakpoints.");
6078 make_cleanup (xfree
, (*canonical
)[k
]);
6083 if (result
.nelts
== 0)
6085 do_cleanups (old_chain
);
6089 discard_cleanups (old_chain
);
6094 /* A canonical line specification of the form FILE:NAME:LINENUM for
6095 symbol table and line data SAL. NULL if insufficient
6096 information. The caller is responsible for releasing any space
6100 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
6104 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
6107 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
6108 + sizeof (sal
.line
) * 3 + 3);
6109 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
6113 /* Return type of Ada breakpoint associated with bp_stat:
6114 0 if not an Ada-specific breakpoint, 1 for break on specific exception,
6115 2 for break on unhandled exception, 3 for assert. */
6118 ada_exception_breakpoint_type (bpstat bs
)
6120 return ((!bs
|| !bs
->breakpoint_at
) ? 0
6121 : bs
->breakpoint_at
->break_on_exception
);
6124 /* True iff FRAME is very likely to be that of a function that is
6125 part of the runtime system. This is all very heuristic, but is
6126 intended to be used as advice as to what frames are uninteresting
6130 is_known_support_routine (struct frame_info
*frame
)
6132 struct frame_info
*next_frame
= get_next_frame (frame
);
6133 /* If frame is not innermost, that normally means that frame->pc
6134 points to *after* the call instruction, and we want to get the line
6135 containing the call, never the next line. But if the next frame is
6136 a signal_handler_caller or a dummy frame, then the next frame was
6137 not entered as the result of a call, and we want to get the line
6138 containing frame->pc. */
6139 const int pc_is_after_call
=
6141 && get_frame_type (next_frame
) != SIGTRAMP_FRAME
6142 && get_frame_type (next_frame
) != DUMMY_FRAME
;
6143 struct symtab_and_line sal
6144 = find_pc_line (get_frame_pc (frame
), pc_is_after_call
);
6150 1. The symtab is null (indicating no debugging symbols)
6151 2. The symtab's filename does not exist.
6152 3. The object file's name is one of the standard libraries.
6153 4. The symtab's file name has the form of an Ada library source file.
6154 5. The function at frame's PC has a GNAT-compiler-generated name. */
6156 if (sal
.symtab
== NULL
)
6159 /* On some systems (e.g. VxWorks), the kernel contains debugging
6160 symbols; in this case, the filename referenced by these symbols
6163 if (stat (sal
.symtab
->filename
, &st
))
6166 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
6168 re_comp (known_runtime_file_name_patterns
[i
]);
6169 if (re_exec (sal
.symtab
->filename
))
6172 if (sal
.symtab
->objfile
!= NULL
)
6174 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
6176 re_comp (known_runtime_file_name_patterns
[i
]);
6177 if (re_exec (sal
.symtab
->objfile
->name
))
6182 /* If the frame PC points after the call instruction, then we need to
6183 decrement it in order to search for the function associated to this
6184 PC. Otherwise, if the associated call was the last instruction of
6185 the function, we might either find the wrong function or even fail
6186 during the function name lookup. */
6187 if (pc_is_after_call
)
6188 func_name
= function_name_from_pc (get_frame_pc (frame
) - 1);
6190 func_name
= function_name_from_pc (get_frame_pc (frame
));
6192 if (func_name
== NULL
)
6195 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
6197 re_comp (known_auxiliary_function_name_patterns
[i
]);
6198 if (re_exec (func_name
))
6205 /* Find the first frame that contains debugging information and that is not
6206 part of the Ada run-time, starting from FI and moving upward. */
6209 ada_find_printable_frame (struct frame_info
*fi
)
6211 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
6213 if (!is_known_support_routine (fi
))
6222 /* Name found for exception associated with last bpstat sent to
6223 ada_adjust_exception_stop. Set to the null string if that bpstat
6224 did not correspond to an Ada exception or no name could be found. */
6226 static char last_exception_name
[256];
6228 /* If BS indicates a stop in an Ada exception, try to go up to a frame
6229 that will be meaningful to the user, and save the name of the last
6230 exception (truncated, if necessary) in last_exception_name. */
6233 ada_adjust_exception_stop (bpstat bs
)
6236 struct frame_info
*fi
;
6238 char *selected_frame_func
;
6241 last_exception_name
[0] = '\0';
6242 fi
= get_selected_frame ();
6243 selected_frame_func
= function_name_from_pc (get_frame_pc (fi
));
6245 switch (ada_exception_breakpoint_type (bs
))
6252 /* Unhandled exceptions. Select the frame corresponding to
6253 ada.exceptions.process_raise_exception. This frame is at
6254 least 2 levels up, so we simply skip the first 2 frames
6255 without checking the name of their associated function. */
6256 for (frame_level
= 0; frame_level
< 2; frame_level
+= 1)
6258 fi
= get_prev_frame (fi
);
6261 const char *func_name
= function_name_from_pc (get_frame_pc (fi
));
6262 if (func_name
!= NULL
6263 && strcmp (func_name
, process_raise_exception_name
) == 0)
6264 break; /* We found the frame we were looking for... */
6265 fi
= get_prev_frame (fi
);
6273 addr
= parse_and_eval_address ("e.full_name");
6276 read_memory (addr
, last_exception_name
, sizeof (last_exception_name
) - 1);
6277 last_exception_name
[sizeof (last_exception_name
) - 1] = '\0';
6278 ada_find_printable_frame (get_selected_frame ());
6281 /* Output Ada exception name (if any) associated with last call to
6282 ada_adjust_exception_stop. */
6285 ada_print_exception_stop (bpstat bs
)
6287 if (last_exception_name
[0] != '\000')
6289 ui_out_text (uiout
, last_exception_name
);
6290 ui_out_text (uiout
, " at ");
6294 /* Parses the CONDITION string associated with a breakpoint exception
6295 to get the name of the exception on which the breakpoint has been
6296 set. The returned string needs to be deallocated after use. */
6299 exception_name_from_cond (const char *condition
)
6301 char *start
, *end
, *exception_name
;
6302 int exception_name_len
;
6304 start
= strrchr (condition
, '&') + 1;
6305 end
= strchr (start
, ')') - 1;
6306 exception_name_len
= end
- start
+ 1;
6309 (char *) xmalloc ((exception_name_len
+ 1) * sizeof (char));
6310 sprintf (exception_name
, "%.*s", exception_name_len
, start
);
6312 return exception_name
;
6315 /* Print Ada-specific exception information about B, other than task
6316 clause. Return non-zero iff B was an Ada exception breakpoint. */
6319 ada_print_exception_breakpoint_nontask (struct breakpoint
*b
)
6321 if (b
->break_on_exception
== 1)
6323 if (b
->cond_string
) /* the breakpoint is on a specific exception. */
6325 char *exception_name
= exception_name_from_cond (b
->cond_string
);
6327 make_cleanup (xfree
, exception_name
);
6329 ui_out_text (uiout
, "on ");
6330 if (ui_out_is_mi_like_p (uiout
))
6331 ui_out_field_string (uiout
, "exception", exception_name
);
6334 ui_out_text (uiout
, "exception ");
6335 ui_out_text (uiout
, exception_name
);
6336 ui_out_text (uiout
, " ");
6340 ui_out_text (uiout
, "on all exceptions");
6342 else if (b
->break_on_exception
== 2)
6343 ui_out_text (uiout
, "on unhandled exception");
6344 else if (b
->break_on_exception
== 3)
6345 ui_out_text (uiout
, "on assert failure");
6351 /* Print task identifier for breakpoint B, if it is an Ada-specific
6352 breakpoint with non-zero tasking information. */
6355 ada_print_exception_breakpoint_task (struct breakpoint
*b
)
6359 ui_out_text (uiout
, " task ");
6360 ui_out_field_int (uiout
, "task", b
->task
);
6365 ada_is_exception_sym (struct symbol
*sym
)
6367 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
6369 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
6370 && SYMBOL_CLASS (sym
) != LOC_BLOCK
6371 && SYMBOL_CLASS (sym
) != LOC_CONST
6372 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
6376 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
6378 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
6379 && SYMBOL_CLASS (sym
) != LOC_BLOCK
6380 && SYMBOL_CLASS (sym
) != LOC_CONST
);
6383 /* Cause the appropriate error if no appropriate runtime symbol is
6384 found to set a breakpoint, using ERR_DESC to describe the
6388 error_breakpoint_runtime_sym_not_found (const char *err_desc
)
6390 /* If we are not debugging an Ada program, we can not put exception
6393 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
6394 error ("Unable to break on %s. Is this an Ada main program?", err_desc
);
6396 /* If the symbol does not exist, then check that the program is
6397 already started, to make sure that shared libraries have been
6398 loaded. If it is not started, this may mean that the symbol is
6399 in a shared library. */
6401 if (ptid_get_pid (inferior_ptid
) == 0)
6402 error ("Unable to break on %s. Try to start the program first.",
6405 /* At this point, we know that we are debugging an Ada program and
6406 that the inferior has been started, but we still are not able to
6407 find the run-time symbols. That can mean that we are in
6408 configurable run time mode, or that a-except as been optimized
6409 out by the linker... In any case, at this point it is not worth
6410 supporting this feature. */
6412 error ("Cannot break on %s in this configuration.", err_desc
);
6415 /* Test if NAME is currently defined, and that either ALLOW_TRAMP or
6416 the symbol is not a shared-library trampoline. Return the result of
6420 is_runtime_sym_defined (const char *name
, int allow_tramp
)
6422 struct minimal_symbol
*msym
;
6424 msym
= lookup_minimal_symbol (name
, NULL
, NULL
);
6425 return (msym
!= NULL
&& msym
->type
!= mst_unknown
6426 && (allow_tramp
|| msym
->type
!= mst_solib_trampoline
));
6429 /* If ARG points to an Ada exception or assert breakpoint, rewrite
6430 into equivalent form. Return resulting argument string. Set
6431 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
6432 break on unhandled, 3 for assert, 0 otherwise. */
6435 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
6439 *break_on_exceptionp
= 0;
6440 if (current_language
->la_language
== language_ada
6441 && strncmp (arg
, "exception", 9) == 0
6442 && (arg
[9] == ' ' || arg
[9] == '\t' || arg
[9] == '\0'))
6444 char *tok
, *end_tok
;
6446 int has_exception_propagation
=
6447 is_runtime_sym_defined (raise_sym_name
, 1);
6449 *break_on_exceptionp
= 1;
6452 while (*tok
== ' ' || *tok
== '\t')
6457 while (*end_tok
!= ' ' && *end_tok
!= '\t' && *end_tok
!= '\000')
6460 toklen
= end_tok
- tok
;
6462 arg
= (char *) xmalloc (sizeof (longest_exception_template
) + toklen
);
6463 make_cleanup (xfree
, arg
);
6466 if (has_exception_propagation
)
6467 sprintf (arg
, "'%s'", raise_sym_name
);
6469 error_breakpoint_runtime_sym_not_found ("exception");
6471 else if (strncmp (tok
, "unhandled", toklen
) == 0)
6473 if (is_runtime_sym_defined (raise_unhandled_sym_name
, 1))
6474 sprintf (arg
, "'%s'", raise_unhandled_sym_name
);
6476 error_breakpoint_runtime_sym_not_found ("exception");
6478 *break_on_exceptionp
= 2;
6482 if (is_runtime_sym_defined (raise_sym_name
, 0))
6483 sprintf (arg
, "'%s' if long_integer(e) = long_integer(&%.*s)",
6484 raise_sym_name
, toklen
, tok
);
6486 error_breakpoint_runtime_sym_not_found ("specific exception");
6489 else if (current_language
->la_language
== language_ada
6490 && strncmp (arg
, "assert", 6) == 0
6491 && (arg
[6] == ' ' || arg
[6] == '\t' || arg
[6] == '\0'))
6493 char *tok
= arg
+ 6;
6495 if (!is_runtime_sym_defined (raise_assert_sym_name
, 1))
6496 error_breakpoint_runtime_sym_not_found ("failed assertion");
6498 *break_on_exceptionp
= 3;
6501 (char *) xmalloc (sizeof (raise_assert_sym_name
) + strlen (tok
) + 2);
6502 make_cleanup (xfree
, arg
);
6503 sprintf (arg
, "'%s'%s", raise_assert_sym_name
, tok
);
6511 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6512 to be invisible to users. */
6515 ada_is_ignored_field (struct type
*type
, int field_num
)
6517 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6521 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6522 return (name
== NULL
6523 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
6527 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6528 pointer or reference type whose ultimate target has a tag field. */
6531 ada_is_tagged_type (struct type
*type
, int refok
)
6533 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
6536 /* True iff TYPE represents the type of X'Tag */
6539 ada_is_tag_type (struct type
*type
)
6541 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6545 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6546 return (name
!= NULL
6547 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6551 /* The type of the tag on VAL. */
6554 ada_tag_type (struct value
*val
)
6556 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 1, 0, NULL
);
6559 /* The value of the tag on VAL. */
6562 ada_value_tag (struct value
*val
)
6564 return ada_value_struct_elt (val
, "_tag", "record");
6567 /* The value of the tag on the object of type TYPE whose contents are
6568 saved at VALADDR, if it is non-null, or is at memory address
6571 static struct value
*
6572 value_tag_from_contents_and_address (struct type
*type
, char *valaddr
,
6575 int tag_byte_offset
, dummy1
, dummy2
;
6576 struct type
*tag_type
;
6577 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6580 char *valaddr1
= (valaddr
== NULL
) ? NULL
: valaddr
+ tag_byte_offset
;
6581 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6583 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6588 static struct type
*
6589 type_from_tag (struct value
*tag
)
6591 const char *type_name
= ada_tag_name (tag
);
6592 if (type_name
!= NULL
)
6593 return ada_find_any_type (ada_encode (type_name
));
6603 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
6604 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
6605 The value stored in ARGS->name is valid until the next call to
6609 ada_tag_name_1 (void *args0
)
6611 struct tag_args
*args
= (struct tag_args
*) args0
;
6612 static char name
[1024];
6616 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
6619 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
6622 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6623 for (p
= name
; *p
!= '\0'; p
+= 1)
6630 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6634 ada_tag_name (struct value
*tag
)
6636 struct tag_args args
;
6637 if (!ada_is_tag_type (VALUE_TYPE (tag
)))
6641 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
6645 /* The parent type of TYPE, or NULL if none. */
6648 ada_parent_type (struct type
*type
)
6652 CHECK_TYPEDEF (type
);
6654 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6657 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6658 if (ada_is_parent_field (type
, i
))
6659 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
6664 /* True iff field number FIELD_NUM of structure type TYPE contains the
6665 parent-type (inherited) fields of a derived type. Assumes TYPE is
6666 a structure type with at least FIELD_NUM+1 fields. */
6669 ada_is_parent_field (struct type
*type
, int field_num
)
6671 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
6672 return (name
!= NULL
6673 && (strncmp (name
, "PARENT", 6) == 0
6674 || strncmp (name
, "_parent", 7) == 0));
6677 /* True iff field number FIELD_NUM of structure type TYPE is a
6678 transparent wrapper field (which should be silently traversed when doing
6679 field selection and flattened when printing). Assumes TYPE is a
6680 structure type with at least FIELD_NUM+1 fields. Such fields are always
6684 ada_is_wrapper_field (struct type
*type
, int field_num
)
6686 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6687 return (name
!= NULL
6688 && (strncmp (name
, "PARENT", 6) == 0
6689 || strcmp (name
, "REP") == 0
6690 || strncmp (name
, "_parent", 7) == 0
6691 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6694 /* True iff field number FIELD_NUM of structure or union type TYPE
6695 is a variant wrapper. Assumes TYPE is a structure type with at least
6696 FIELD_NUM+1 fields. */
6699 ada_is_variant_part (struct type
*type
, int field_num
)
6701 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6702 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6703 || (is_dynamic_field (type
, field_num
)
6704 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
6708 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6709 whose discriminants are contained in the record type OUTER_TYPE,
6710 returns the type of the controlling discriminant for the variant. */
6713 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6715 char *name
= ada_variant_discrim_name (var_type
);
6717 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
6719 return builtin_type_int
;
6724 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6725 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6726 represents a 'when others' clause; otherwise 0. */
6729 ada_is_others_clause (struct type
*type
, int field_num
)
6731 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6732 return (name
!= NULL
&& name
[0] == 'O');
6735 /* Assuming that TYPE0 is the type of the variant part of a record,
6736 returns the name of the discriminant controlling the variant.
6737 The value is valid until the next call to ada_variant_discrim_name. */
6740 ada_variant_discrim_name (struct type
*type0
)
6742 static char *result
= NULL
;
6743 static size_t result_len
= 0;
6746 const char *discrim_end
;
6747 const char *discrim_start
;
6749 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6750 type
= TYPE_TARGET_TYPE (type0
);
6754 name
= ada_type_name (type
);
6756 if (name
== NULL
|| name
[0] == '\000')
6759 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6762 if (strncmp (discrim_end
, "___XVN", 6) == 0)
6765 if (discrim_end
== name
)
6768 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6771 if (discrim_start
== name
+ 1)
6773 if ((discrim_start
> name
+ 3
6774 && strncmp (discrim_start
- 3, "___", 3) == 0)
6775 || discrim_start
[-1] == '.')
6779 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6780 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6781 result
[discrim_end
- discrim_start
] = '\0';
6785 /* Scan STR for a subtype-encoded number, beginning at position K.
6786 Put the position of the character just past the number scanned in
6787 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6788 Return 1 if there was a valid number at the given position, and 0
6789 otherwise. A "subtype-encoded" number consists of the absolute value
6790 in decimal, followed by the letter 'm' to indicate a negative number.
6791 Assumes 0m does not occur. */
6794 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6798 if (!isdigit (str
[k
]))
6801 /* Do it the hard way so as not to make any assumption about
6802 the relationship of unsigned long (%lu scan format code) and
6805 while (isdigit (str
[k
]))
6807 RU
= RU
* 10 + (str
[k
] - '0');
6814 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6820 /* NOTE on the above: Technically, C does not say what the results of
6821 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6822 number representable as a LONGEST (although either would probably work
6823 in most implementations). When RU>0, the locution in the then branch
6824 above is always equivalent to the negative of RU. */
6831 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6832 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6833 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6836 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6838 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6851 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6860 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6861 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6863 if (val
>= L
&& val
<= U
)
6875 /* FIXME: Lots of redundancy below. Try to consolidate. */
6877 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6878 ARG_TYPE, extract and return the value of one of its (non-static)
6879 fields. FIELDNO says which field. Differs from value_primitive_field
6880 only in that it can handle packed values of arbitrary type. */
6882 static struct value
*
6883 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6884 struct type
*arg_type
)
6888 CHECK_TYPEDEF (arg_type
);
6889 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
6891 /* Handle packed fields. */
6893 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
6895 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6896 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6898 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
6899 offset
+ bit_pos
/ 8,
6900 bit_pos
% 8, bit_size
, type
);
6903 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6906 /* Find field with name NAME in object of type TYPE. If found, return 1
6907 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
6908 OFFSET + the byte offset of the field within an object of that type,
6909 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
6910 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
6911 Looks inside wrappers for the field. Returns 0 if field not
6914 find_struct_field (char *name
, struct type
*type
, int offset
,
6915 struct type
**field_type_p
,
6916 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
6920 CHECK_TYPEDEF (type
);
6921 *field_type_p
= NULL
;
6922 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
6924 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
6926 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6927 int fld_offset
= offset
+ bit_pos
/ 8;
6928 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6930 if (t_field_name
== NULL
)
6933 else if (field_name_match (t_field_name
, name
))
6935 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6936 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6937 *byte_offset_p
= fld_offset
;
6938 *bit_offset_p
= bit_pos
% 8;
6939 *bit_size_p
= bit_size
;
6942 else if (ada_is_wrapper_field (type
, i
))
6944 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6945 field_type_p
, byte_offset_p
, bit_offset_p
,
6949 else if (ada_is_variant_part (type
, i
))
6952 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
6954 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6956 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6958 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6959 field_type_p
, byte_offset_p
,
6960 bit_offset_p
, bit_size_p
))
6970 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6971 and search in it assuming it has (class) type TYPE.
6972 If found, return value, else return NULL.
6974 Searches recursively through wrapper fields (e.g., '_parent'). */
6976 static struct value
*
6977 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6981 CHECK_TYPEDEF (type
);
6983 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
6985 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6987 if (t_field_name
== NULL
)
6990 else if (field_name_match (t_field_name
, name
))
6991 return ada_value_primitive_field (arg
, offset
, i
, type
);
6993 else if (ada_is_wrapper_field (type
, i
))
6995 struct value
*v
= /* Do not let indent join lines here. */
6996 ada_search_struct_field (name
, arg
,
6997 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6998 TYPE_FIELD_TYPE (type
, i
));
7003 else if (ada_is_variant_part (type
, i
))
7006 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7007 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7009 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7011 struct value
*v
= ada_search_struct_field
/* Force line break. */
7013 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7014 TYPE_FIELD_TYPE (field_type
, j
));
7023 /* Given ARG, a value of type (pointer or reference to a)*
7024 structure/union, extract the component named NAME from the ultimate
7025 target structure/union and return it as a value with its
7026 appropriate type. If ARG is a pointer or reference and the field
7027 is not packed, returns a reference to the field, otherwise the
7028 value of the field (an lvalue if ARG is an lvalue).
7030 The routine searches for NAME among all members of the structure itself
7031 and (recursively) among all members of any wrapper members
7034 ERR is a name (for use in error messages) that identifies the class
7035 of entity that ARG is supposed to be. ERR may be null, indicating
7036 that on error, the function simply returns NULL, and does not
7037 throw an error. (FIXME: True only if ARG is a pointer or reference
7041 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
7043 struct type
*t
, *t1
;
7047 t1
= t
= check_typedef (VALUE_TYPE (arg
));
7048 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7050 t1
= TYPE_TARGET_TYPE (t
);
7056 error ("Bad value type in a %s.", err
);
7059 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7066 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7068 t1
= TYPE_TARGET_TYPE (t
);
7074 error ("Bad value type in a %s.", err
);
7077 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7079 arg
= value_ind (arg
);
7086 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7091 error ("Attempt to extract a component of a value that is not a %s.",
7096 v
= ada_search_struct_field (name
, arg
, 0, t
);
7099 int bit_offset
, bit_size
, byte_offset
;
7100 struct type
*field_type
;
7103 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7104 address
= value_as_address (arg
);
7106 address
= unpack_pointer (t
, VALUE_CONTENTS (arg
));
7108 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
7109 if (find_struct_field (name
, t1
, 0,
7110 &field_type
, &byte_offset
, &bit_offset
,
7115 arg
= ada_value_ind (arg
);
7116 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7117 bit_offset
, bit_size
,
7121 v
= value_from_pointer (lookup_reference_type (field_type
),
7122 address
+ byte_offset
);
7126 if (v
== NULL
&& err
!= NULL
)
7127 error ("There is no member named %s.", name
);
7132 /* Given a type TYPE, look up the type of the component of type named NAME.
7133 If DISPP is non-null, add its byte displacement from the beginning of a
7134 structure (pointed to by a value) of type TYPE to *DISPP (does not
7135 work for packed fields).
7137 Matches any field whose name has NAME as a prefix, possibly
7140 TYPE can be either a struct or union. If REFOK, TYPE may also
7141 be a (pointer or reference)+ to a struct or union, and the
7142 ultimate target type will be searched.
7144 Looks recursively into variant clauses and parent types.
7146 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7147 TYPE is not a type of the right kind. */
7149 static struct type
*
7150 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
7151 int noerr
, int *dispp
)
7158 if (refok
&& type
!= NULL
)
7161 CHECK_TYPEDEF (type
);
7162 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7163 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7165 type
= TYPE_TARGET_TYPE (type
);
7169 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7170 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7176 target_terminal_ours ();
7177 gdb_flush (gdb_stdout
);
7178 fprintf_unfiltered (gdb_stderr
, "Type ");
7180 fprintf_unfiltered (gdb_stderr
, "(null)");
7182 type_print (type
, "", gdb_stderr
, -1);
7183 error (" is not a structure or union type");
7187 type
= to_static_fixed_type (type
);
7189 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7191 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7195 if (t_field_name
== NULL
)
7198 else if (field_name_match (t_field_name
, name
))
7201 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
7202 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
7205 else if (ada_is_wrapper_field (type
, i
))
7208 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7213 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7218 else if (ada_is_variant_part (type
, i
))
7221 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7223 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7226 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
7231 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7242 target_terminal_ours ();
7243 gdb_flush (gdb_stdout
);
7244 fprintf_unfiltered (gdb_stderr
, "Type ");
7245 type_print (type
, "", gdb_stderr
, -1);
7246 fprintf_unfiltered (gdb_stderr
, " has no component named ");
7247 error ("%s", name
== NULL
? "<null>" : name
);
7253 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7254 within a value of type OUTER_TYPE that is stored in GDB at
7255 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7256 numbering from 0) is applicable. Returns -1 if none are. */
7259 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7260 char *outer_valaddr
)
7265 struct type
*discrim_type
;
7266 char *discrim_name
= ada_variant_discrim_name (var_type
);
7267 LONGEST discrim_val
;
7271 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
7272 if (discrim_type
== NULL
)
7274 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
7277 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7279 if (ada_is_others_clause (var_type
, i
))
7281 else if (ada_in_variant (discrim_val
, var_type
, i
))
7285 return others_clause
;
7290 /* Dynamic-Sized Records */
7292 /* Strategy: The type ostensibly attached to a value with dynamic size
7293 (i.e., a size that is not statically recorded in the debugging
7294 data) does not accurately reflect the size or layout of the value.
7295 Our strategy is to convert these values to values with accurate,
7296 conventional types that are constructed on the fly. */
7298 /* There is a subtle and tricky problem here. In general, we cannot
7299 determine the size of dynamic records without its data. However,
7300 the 'struct value' data structure, which GDB uses to represent
7301 quantities in the inferior process (the target), requires the size
7302 of the type at the time of its allocation in order to reserve space
7303 for GDB's internal copy of the data. That's why the
7304 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7305 rather than struct value*s.
7307 However, GDB's internal history variables ($1, $2, etc.) are
7308 struct value*s containing internal copies of the data that are not, in
7309 general, the same as the data at their corresponding addresses in
7310 the target. Fortunately, the types we give to these values are all
7311 conventional, fixed-size types (as per the strategy described
7312 above), so that we don't usually have to perform the
7313 'to_fixed_xxx_type' conversions to look at their values.
7314 Unfortunately, there is one exception: if one of the internal
7315 history variables is an array whose elements are unconstrained
7316 records, then we will need to create distinct fixed types for each
7317 element selected. */
7319 /* The upshot of all of this is that many routines take a (type, host
7320 address, target address) triple as arguments to represent a value.
7321 The host address, if non-null, is supposed to contain an internal
7322 copy of the relevant data; otherwise, the program is to consult the
7323 target at the target address. */
7325 /* Assuming that VAL0 represents a pointer value, the result of
7326 dereferencing it. Differs from value_ind in its treatment of
7327 dynamic-sized types. */
7330 ada_value_ind (struct value
*val0
)
7332 struct value
*val
= unwrap_value (value_ind (val0
));
7333 return ada_to_fixed_value (val
);
7336 /* The value resulting from dereferencing any "reference to"
7337 qualifiers on VAL0. */
7339 static struct value
*
7340 ada_coerce_ref (struct value
*val0
)
7342 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
7344 struct value
*val
= val0
;
7346 val
= unwrap_value (val
);
7347 return ada_to_fixed_value (val
);
7353 /* Return OFF rounded upward if necessary to a multiple of
7354 ALIGNMENT (a power of 2). */
7357 align_value (unsigned int off
, unsigned int alignment
)
7359 return (off
+ alignment
- 1) & ~(alignment
- 1);
7362 /* Return the bit alignment required for field #F of template type TYPE. */
7365 field_alignment (struct type
*type
, int f
)
7367 const char *name
= TYPE_FIELD_NAME (type
, f
);
7368 int len
= (name
== NULL
) ? 0 : strlen (name
);
7371 if (!isdigit (name
[len
- 1]))
7374 if (isdigit (name
[len
- 2]))
7375 align_offset
= len
- 2;
7377 align_offset
= len
- 1;
7379 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
7380 return TARGET_CHAR_BIT
;
7382 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7385 /* Find a symbol named NAME. Ignores ambiguity. */
7388 ada_find_any_symbol (const char *name
)
7392 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7393 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7396 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7400 /* Find a type named NAME. Ignores ambiguity. */
7403 ada_find_any_type (const char *name
)
7405 struct symbol
*sym
= ada_find_any_symbol (name
);
7408 return SYMBOL_TYPE (sym
);
7413 /* Given a symbol NAME and its associated BLOCK, search all symbols
7414 for its ___XR counterpart, which is the ``renaming'' symbol
7415 associated to NAME. Return this symbol if found, return
7419 ada_find_renaming_symbol (const char *name
, struct block
*block
)
7421 const struct symbol
*function_sym
= block_function (block
);
7424 if (function_sym
!= NULL
)
7426 /* If the symbol is defined inside a function, NAME is not fully
7427 qualified. This means we need to prepend the function name
7428 as well as adding the ``___XR'' suffix to build the name of
7429 the associated renaming symbol. */
7430 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
7431 const int function_name_len
= strlen (function_name
);
7432 const int rename_len
= function_name_len
+ 2 /* "__" */
7433 + strlen (name
) + 6 /* "___XR\0" */ ;
7435 /* Library-level functions are a special case, as GNAT adds
7436 a ``_ada_'' prefix to the function name to avoid namespace
7437 pollution. However, the renaming symbol themselves do not
7438 have this prefix, so we need to skip this prefix if present. */
7439 if (function_name_len
> 5 /* "_ada_" */
7440 && strstr (function_name
, "_ada_") == function_name
)
7441 function_name
= function_name
+ 5;
7443 rename
= (char *) alloca (rename_len
* sizeof (char));
7444 sprintf (rename
, "%s__%s___XR", function_name
, name
);
7448 const int rename_len
= strlen (name
) + 6;
7449 rename
= (char *) alloca (rename_len
* sizeof (char));
7450 sprintf (rename
, "%s___XR", name
);
7453 return ada_find_any_symbol (rename
);
7456 /* Because of GNAT encoding conventions, several GDB symbols may match a
7457 given type name. If the type denoted by TYPE0 is to be preferred to
7458 that of TYPE1 for purposes of type printing, return non-zero;
7459 otherwise return 0. */
7462 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7466 else if (type0
== NULL
)
7468 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
7470 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
7472 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
7474 else if (ada_is_packed_array_type (type0
))
7476 else if (ada_is_array_descriptor_type (type0
)
7477 && !ada_is_array_descriptor_type (type1
))
7479 else if (ada_renaming_type (type0
) != NULL
7480 && ada_renaming_type (type1
) == NULL
)
7485 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7486 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7489 ada_type_name (struct type
*type
)
7493 else if (TYPE_NAME (type
) != NULL
)
7494 return TYPE_NAME (type
);
7496 return TYPE_TAG_NAME (type
);
7499 /* Find a parallel type to TYPE whose name is formed by appending
7500 SUFFIX to the name of TYPE. */
7503 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7506 static size_t name_len
= 0;
7508 char *typename
= ada_type_name (type
);
7510 if (typename
== NULL
)
7513 len
= strlen (typename
);
7515 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
7517 strcpy (name
, typename
);
7518 strcpy (name
+ len
, suffix
);
7520 return ada_find_any_type (name
);
7524 /* If TYPE is a variable-size record type, return the corresponding template
7525 type describing its fields. Otherwise, return NULL. */
7527 static struct type
*
7528 dynamic_template_type (struct type
*type
)
7530 CHECK_TYPEDEF (type
);
7532 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
7533 || ada_type_name (type
) == NULL
)
7537 int len
= strlen (ada_type_name (type
));
7538 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7541 return ada_find_parallel_type (type
, "___XVE");
7545 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7546 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7549 is_dynamic_field (struct type
*templ_type
, int field_num
)
7551 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7553 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
7554 && strstr (name
, "___XVL") != NULL
;
7557 /* The index of the variant field of TYPE, or -1 if TYPE does not
7558 represent a variant record type. */
7561 variant_field_index (struct type
*type
)
7565 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
7568 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
7570 if (ada_is_variant_part (type
, f
))
7576 /* A record type with no fields. */
7578 static struct type
*
7579 empty_record (struct objfile
*objfile
)
7581 struct type
*type
= alloc_type (objfile
);
7582 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
7583 TYPE_NFIELDS (type
) = 0;
7584 TYPE_FIELDS (type
) = NULL
;
7585 TYPE_NAME (type
) = "<empty>";
7586 TYPE_TAG_NAME (type
) = NULL
;
7587 TYPE_FLAGS (type
) = 0;
7588 TYPE_LENGTH (type
) = 0;
7592 /* An ordinary record type (with fixed-length fields) that describes
7593 the value of type TYPE at VALADDR or ADDRESS (see comments at
7594 the beginning of this section) VAL according to GNAT conventions.
7595 DVAL0 should describe the (portion of a) record that contains any
7596 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
7597 an outer-level type (i.e., as opposed to a branch of a variant.) A
7598 variant field (unless unchecked) is replaced by a particular branch
7601 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7602 length are not statically known are discarded. As a consequence,
7603 VALADDR, ADDRESS and DVAL0 are ignored.
7605 NOTE: Limitations: For now, we assume that dynamic fields and
7606 variants occupy whole numbers of bytes. However, they need not be
7610 ada_template_to_fixed_record_type_1 (struct type
*type
, char *valaddr
,
7611 CORE_ADDR address
, struct value
*dval0
,
7612 int keep_dynamic_fields
)
7614 struct value
*mark
= value_mark ();
7617 int nfields
, bit_len
;
7620 int fld_bit_len
, bit_incr
;
7623 /* Compute the number of fields in this record type that are going
7624 to be processed: unless keep_dynamic_fields, this includes only
7625 fields whose position and length are static will be processed. */
7626 if (keep_dynamic_fields
)
7627 nfields
= TYPE_NFIELDS (type
);
7631 while (nfields
< TYPE_NFIELDS (type
)
7632 && !ada_is_variant_part (type
, nfields
)
7633 && !is_dynamic_field (type
, nfields
))
7637 rtype
= alloc_type (TYPE_OBJFILE (type
));
7638 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7639 INIT_CPLUS_SPECIFIC (rtype
);
7640 TYPE_NFIELDS (rtype
) = nfields
;
7641 TYPE_FIELDS (rtype
) = (struct field
*)
7642 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7643 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
7644 TYPE_NAME (rtype
) = ada_type_name (type
);
7645 TYPE_TAG_NAME (rtype
) = NULL
;
7646 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
7652 for (f
= 0; f
< nfields
; f
+= 1)
7656 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
7657 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
7658 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7660 if (ada_is_variant_part (type
, f
))
7663 fld_bit_len
= bit_incr
= 0;
7665 else if (is_dynamic_field (type
, f
))
7668 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7672 TYPE_FIELD_TYPE (rtype
, f
) =
7675 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
7676 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7677 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7678 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7679 bit_incr
= fld_bit_len
=
7680 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
7684 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
7685 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7686 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7687 bit_incr
= fld_bit_len
=
7688 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7690 bit_incr
= fld_bit_len
=
7691 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
7693 if (off
+ fld_bit_len
> bit_len
)
7694 bit_len
= off
+ fld_bit_len
;
7696 TYPE_LENGTH (rtype
) =
7697 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7700 /* We handle the variant part, if any, at the end because of certain
7701 odd cases in which it is re-ordered so as NOT the last field of
7702 the record. This can happen in the presence of representation
7704 if (variant_field
>= 0)
7706 struct type
*branch_type
;
7708 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7711 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7716 to_fixed_variant_branch_type
7717 (TYPE_FIELD_TYPE (type
, variant_field
),
7718 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7719 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7720 if (branch_type
== NULL
)
7722 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
7723 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7724 TYPE_NFIELDS (rtype
) -= 1;
7728 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7729 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7731 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
7733 if (off
+ fld_bit_len
> bit_len
)
7734 bit_len
= off
+ fld_bit_len
;
7735 TYPE_LENGTH (rtype
) =
7736 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7740 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
7742 value_free_to_mark (mark
);
7743 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7744 error ("record type with dynamic size is larger than varsize-limit");
7748 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7751 static struct type
*
7752 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
7753 CORE_ADDR address
, struct value
*dval0
)
7755 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7759 /* An ordinary record type in which ___XVL-convention fields and
7760 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7761 static approximations, containing all possible fields. Uses
7762 no runtime values. Useless for use in values, but that's OK,
7763 since the results are used only for type determinations. Works on both
7764 structs and unions. Representation note: to save space, we memorize
7765 the result of this function in the TYPE_TARGET_TYPE of the
7768 static struct type
*
7769 template_to_static_fixed_type (struct type
*type0
)
7775 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7776 return TYPE_TARGET_TYPE (type0
);
7778 nfields
= TYPE_NFIELDS (type0
);
7781 for (f
= 0; f
< nfields
; f
+= 1)
7783 struct type
*field_type
= CHECK_TYPEDEF (TYPE_FIELD_TYPE (type0
, f
));
7784 struct type
*new_type
;
7786 if (is_dynamic_field (type0
, f
))
7787 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7789 new_type
= to_static_fixed_type (field_type
);
7790 if (type
== type0
&& new_type
!= field_type
)
7792 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
7793 TYPE_CODE (type
) = TYPE_CODE (type0
);
7794 INIT_CPLUS_SPECIFIC (type
);
7795 TYPE_NFIELDS (type
) = nfields
;
7796 TYPE_FIELDS (type
) = (struct field
*)
7797 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7798 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7799 sizeof (struct field
) * nfields
);
7800 TYPE_NAME (type
) = ada_type_name (type0
);
7801 TYPE_TAG_NAME (type
) = NULL
;
7802 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
7803 TYPE_LENGTH (type
) = 0;
7805 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7806 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7811 /* Given an object of type TYPE whose contents are at VALADDR and
7812 whose address in memory is ADDRESS, returns a revision of TYPE --
7813 a non-dynamic-sized record with a variant part -- in which
7814 the variant part is replaced with the appropriate branch. Looks
7815 for discriminant values in DVAL0, which can be NULL if the record
7816 contains the necessary discriminant values. */
7818 static struct type
*
7819 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
7820 CORE_ADDR address
, struct value
*dval0
)
7822 struct value
*mark
= value_mark ();
7825 struct type
*branch_type
;
7826 int nfields
= TYPE_NFIELDS (type
);
7827 int variant_field
= variant_field_index (type
);
7829 if (variant_field
== -1)
7833 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7837 rtype
= alloc_type (TYPE_OBJFILE (type
));
7838 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7839 INIT_CPLUS_SPECIFIC (rtype
);
7840 TYPE_NFIELDS (rtype
) = nfields
;
7841 TYPE_FIELDS (rtype
) =
7842 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7843 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7844 sizeof (struct field
) * nfields
);
7845 TYPE_NAME (rtype
) = ada_type_name (type
);
7846 TYPE_TAG_NAME (rtype
) = NULL
;
7847 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
7848 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7850 branch_type
= to_fixed_variant_branch_type
7851 (TYPE_FIELD_TYPE (type
, variant_field
),
7852 cond_offset_host (valaddr
,
7853 TYPE_FIELD_BITPOS (type
, variant_field
)
7855 cond_offset_target (address
,
7856 TYPE_FIELD_BITPOS (type
, variant_field
)
7857 / TARGET_CHAR_BIT
), dval
);
7858 if (branch_type
== NULL
)
7861 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7862 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7863 TYPE_NFIELDS (rtype
) -= 1;
7867 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7868 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7869 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7870 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7872 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7874 value_free_to_mark (mark
);
7878 /* An ordinary record type (with fixed-length fields) that describes
7879 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7880 beginning of this section]. Any necessary discriminants' values
7881 should be in DVAL, a record value; it may be NULL if the object
7882 at ADDR itself contains any necessary discriminant values.
7883 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7884 values from the record are needed. Except in the case that DVAL,
7885 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7886 unchecked) is replaced by a particular branch of the variant.
7888 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7889 is questionable and may be removed. It can arise during the
7890 processing of an unconstrained-array-of-record type where all the
7891 variant branches have exactly the same size. This is because in
7892 such cases, the compiler does not bother to use the XVS convention
7893 when encoding the record. I am currently dubious of this
7894 shortcut and suspect the compiler should be altered. FIXME. */
7896 static struct type
*
7897 to_fixed_record_type (struct type
*type0
, char *valaddr
,
7898 CORE_ADDR address
, struct value
*dval
)
7900 struct type
*templ_type
;
7902 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
7905 templ_type
= dynamic_template_type (type0
);
7907 if (templ_type
!= NULL
)
7908 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7909 else if (variant_field_index (type0
) >= 0)
7911 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7913 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7918 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
7924 /* An ordinary record type (with fixed-length fields) that describes
7925 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7926 union type. Any necessary discriminants' values should be in DVAL,
7927 a record value. That is, this routine selects the appropriate
7928 branch of the union at ADDR according to the discriminant value
7929 indicated in the union's type name. */
7931 static struct type
*
7932 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
7933 CORE_ADDR address
, struct value
*dval
)
7936 struct type
*templ_type
;
7937 struct type
*var_type
;
7939 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7940 var_type
= TYPE_TARGET_TYPE (var_type0
);
7942 var_type
= var_type0
;
7944 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7946 if (templ_type
!= NULL
)
7947 var_type
= templ_type
;
7950 ada_which_variant_applies (var_type
,
7951 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
7954 return empty_record (TYPE_OBJFILE (var_type
));
7955 else if (is_dynamic_field (var_type
, which
))
7956 return to_fixed_record_type
7957 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7958 valaddr
, address
, dval
);
7959 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7961 to_fixed_record_type
7962 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7964 return TYPE_FIELD_TYPE (var_type
, which
);
7967 /* Assuming that TYPE0 is an array type describing the type of a value
7968 at ADDR, and that DVAL describes a record containing any
7969 discriminants used in TYPE0, returns a type for the value that
7970 contains no dynamic components (that is, no components whose sizes
7971 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7972 true, gives an error message if the resulting type's size is over
7975 static struct type
*
7976 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7979 struct type
*index_type_desc
;
7980 struct type
*result
;
7982 if (ada_is_packed_array_type (type0
) /* revisit? */
7983 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
7986 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7987 if (index_type_desc
== NULL
)
7989 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
7990 /* NOTE: elt_type---the fixed version of elt_type0---should never
7991 depend on the contents of the array in properly constructed
7993 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
7995 if (elt_type0
== elt_type
)
7998 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7999 elt_type
, TYPE_INDEX_TYPE (type0
));
8004 struct type
*elt_type0
;
8007 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8008 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8010 /* NOTE: result---the fixed version of elt_type0---should never
8011 depend on the contents of the array in properly constructed
8013 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
8014 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8016 struct type
*range_type
=
8017 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
8018 dval
, TYPE_OBJFILE (type0
));
8019 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
8020 result
, range_type
);
8022 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8023 error ("array type with dynamic size is larger than varsize-limit");
8026 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
8031 /* A standard type (containing no dynamically sized components)
8032 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8033 DVAL describes a record containing any discriminants used in TYPE0,
8034 and may be NULL if there are none, or if the object of type TYPE at
8035 ADDRESS or in VALADDR contains these discriminants. */
8038 ada_to_fixed_type (struct type
*type
, char *valaddr
,
8039 CORE_ADDR address
, struct value
*dval
)
8041 CHECK_TYPEDEF (type
);
8042 switch (TYPE_CODE (type
))
8046 case TYPE_CODE_STRUCT
:
8048 struct type
*static_type
= to_static_fixed_type (type
);
8049 if (ada_is_tagged_type (static_type
, 0))
8051 struct type
*real_type
=
8052 type_from_tag (value_tag_from_contents_and_address (static_type
,
8055 if (real_type
!= NULL
)
8058 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
8060 case TYPE_CODE_ARRAY
:
8061 return to_fixed_array_type (type
, dval
, 1);
8062 case TYPE_CODE_UNION
:
8066 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8070 /* A standard (static-sized) type corresponding as well as possible to
8071 TYPE0, but based on no runtime data. */
8073 static struct type
*
8074 to_static_fixed_type (struct type
*type0
)
8081 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
8084 CHECK_TYPEDEF (type0
);
8086 switch (TYPE_CODE (type0
))
8090 case TYPE_CODE_STRUCT
:
8091 type
= dynamic_template_type (type0
);
8093 return template_to_static_fixed_type (type
);
8095 return template_to_static_fixed_type (type0
);
8096 case TYPE_CODE_UNION
:
8097 type
= ada_find_parallel_type (type0
, "___XVU");
8099 return template_to_static_fixed_type (type
);
8101 return template_to_static_fixed_type (type0
);
8105 /* A static approximation of TYPE with all type wrappers removed. */
8107 static struct type
*
8108 static_unwrap_type (struct type
*type
)
8110 if (ada_is_aligner_type (type
))
8112 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
8113 if (ada_type_name (type1
) == NULL
)
8114 TYPE_NAME (type1
) = ada_type_name (type
);
8116 return static_unwrap_type (type1
);
8120 struct type
*raw_real_type
= ada_get_base_type (type
);
8121 if (raw_real_type
== type
)
8124 return to_static_fixed_type (raw_real_type
);
8128 /* In some cases, incomplete and private types require
8129 cross-references that are not resolved as records (for example,
8131 type FooP is access Foo;
8133 type Foo is array ...;
8134 ). In these cases, since there is no mechanism for producing
8135 cross-references to such types, we instead substitute for FooP a
8136 stub enumeration type that is nowhere resolved, and whose tag is
8137 the name of the actual type. Call these types "non-record stubs". */
8139 /* A type equivalent to TYPE that is not a non-record stub, if one
8140 exists, otherwise TYPE. */
8143 ada_completed_type (struct type
*type
)
8145 CHECK_TYPEDEF (type
);
8146 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
8147 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
8148 || TYPE_TAG_NAME (type
) == NULL
)
8152 char *name
= TYPE_TAG_NAME (type
);
8153 struct type
*type1
= ada_find_any_type (name
);
8154 return (type1
== NULL
) ? type
: type1
;
8158 /* A value representing the data at VALADDR/ADDRESS as described by
8159 type TYPE0, but with a standard (static-sized) type that correctly
8160 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8161 type, then return VAL0 [this feature is simply to avoid redundant
8162 creation of struct values]. */
8164 static struct value
*
8165 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8168 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
8169 if (type
== type0
&& val0
!= NULL
)
8172 return value_from_contents_and_address (type
, 0, address
);
8175 /* A value representing VAL, but with a standard (static-sized) type
8176 that correctly describes it. Does not necessarily create a new
8179 static struct value
*
8180 ada_to_fixed_value (struct value
*val
)
8182 return ada_to_fixed_value_create (VALUE_TYPE (val
),
8183 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
8187 /* If the PC is pointing inside a function prologue, then re-adjust it
8188 past this prologue. */
8191 adjust_pc_past_prologue (CORE_ADDR
*pc
)
8193 struct symbol
*func_sym
= find_pc_function (*pc
);
8197 const struct symtab_and_line sal
=
8198 find_function_start_sal (func_sym
, 1);
8205 /* A value representing VAL, but with a standard (static-sized) type
8206 chosen to approximate the real type of VAL as well as possible, but
8207 without consulting any runtime values. For Ada dynamic-sized
8208 types, therefore, the type of the result is likely to be inaccurate. */
8211 ada_to_static_fixed_value (struct value
*val
)
8214 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
8215 if (type
== VALUE_TYPE (val
))
8218 return coerce_unspec_val_to_type (val
, type
);
8224 /* Table mapping attribute numbers to names.
8225 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8227 static const char *attribute_names
[] = {
8245 ada_attribute_name (enum exp_opcode n
)
8247 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8248 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8250 return attribute_names
[0];
8253 /* Evaluate the 'POS attribute applied to ARG. */
8256 pos_atr (struct value
*arg
)
8258 struct type
*type
= VALUE_TYPE (arg
);
8260 if (!discrete_type_p (type
))
8261 error ("'POS only defined on discrete types");
8263 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8266 LONGEST v
= value_as_long (arg
);
8268 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
8270 if (v
== TYPE_FIELD_BITPOS (type
, i
))
8273 error ("enumeration value is invalid: can't find 'POS");
8276 return value_as_long (arg
);
8279 static struct value
*
8280 value_pos_atr (struct value
*arg
)
8282 return value_from_longest (builtin_type_ada_int
, pos_atr (arg
));
8285 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8287 static struct value
*
8288 value_val_atr (struct type
*type
, struct value
*arg
)
8290 if (!discrete_type_p (type
))
8291 error ("'VAL only defined on discrete types");
8292 if (!integer_type_p (VALUE_TYPE (arg
)))
8293 error ("'VAL requires integral argument");
8295 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8297 long pos
= value_as_long (arg
);
8298 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
8299 error ("argument to 'VAL out of range");
8300 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
8303 return value_from_longest (type
, value_as_long (arg
));
8309 /* True if TYPE appears to be an Ada character type.
8310 [At the moment, this is true only for Character and Wide_Character;
8311 It is a heuristic test that could stand improvement]. */
8314 ada_is_character_type (struct type
*type
)
8316 const char *name
= ada_type_name (type
);
8319 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
8320 || TYPE_CODE (type
) == TYPE_CODE_INT
8321 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8322 && (strcmp (name
, "character") == 0
8323 || strcmp (name
, "wide_character") == 0
8324 || strcmp (name
, "unsigned char") == 0);
8327 /* True if TYPE appears to be an Ada string type. */
8330 ada_is_string_type (struct type
*type
)
8332 CHECK_TYPEDEF (type
);
8334 && TYPE_CODE (type
) != TYPE_CODE_PTR
8335 && (ada_is_simple_array_type (type
)
8336 || ada_is_array_descriptor_type (type
))
8337 && ada_array_arity (type
) == 1)
8339 struct type
*elttype
= ada_array_element_type (type
, 1);
8341 return ada_is_character_type (elttype
);
8348 /* True if TYPE is a struct type introduced by the compiler to force the
8349 alignment of a value. Such types have a single field with a
8350 distinctive name. */
8353 ada_is_aligner_type (struct type
*type
)
8355 CHECK_TYPEDEF (type
);
8356 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
8357 && TYPE_NFIELDS (type
) == 1
8358 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
8361 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8362 the parallel type. */
8365 ada_get_base_type (struct type
*raw_type
)
8367 struct type
*real_type_namer
;
8368 struct type
*raw_real_type
;
8370 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
8373 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
8374 if (real_type_namer
== NULL
8375 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
8376 || TYPE_NFIELDS (real_type_namer
) != 1)
8379 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
8380 if (raw_real_type
== NULL
)
8383 return raw_real_type
;
8386 /* The type of value designated by TYPE, with all aligners removed. */
8389 ada_aligned_type (struct type
*type
)
8391 if (ada_is_aligner_type (type
))
8392 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
8394 return ada_get_base_type (type
);
8398 /* The address of the aligned value in an object at address VALADDR
8399 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
8402 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
8404 if (ada_is_aligner_type (type
))
8405 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
8407 TYPE_FIELD_BITPOS (type
,
8408 0) / TARGET_CHAR_BIT
);
8415 /* The printed representation of an enumeration literal with encoded
8416 name NAME. The value is good to the next call of ada_enum_name. */
8418 ada_enum_name (const char *name
)
8420 static char *result
;
8421 static size_t result_len
= 0;
8424 /* First, unqualify the enumeration name:
8425 1. Search for the last '.' character. If we find one, then skip
8426 all the preceeding characters, the unqualified name starts
8427 right after that dot.
8428 2. Otherwise, we may be debugging on a target where the compiler
8429 translates dots into "__". Search forward for double underscores,
8430 but stop searching when we hit an overloading suffix, which is
8431 of the form "__" followed by digits. */
8433 if ((tmp
= strrchr (name
, '.')) != NULL
)
8437 while ((tmp
= strstr (name
, "__")) != NULL
)
8439 if (isdigit (tmp
[2]))
8449 if (name
[1] == 'U' || name
[1] == 'W')
8451 if (sscanf (name
+ 2, "%x", &v
) != 1)
8457 GROW_VECT (result
, result_len
, 16);
8458 if (isascii (v
) && isprint (v
))
8459 sprintf (result
, "'%c'", v
);
8460 else if (name
[1] == 'U')
8461 sprintf (result
, "[\"%02x\"]", v
);
8463 sprintf (result
, "[\"%04x\"]", v
);
8469 if ((tmp
= strstr (name
, "__")) != NULL
8470 || (tmp
= strstr (name
, "$")) != NULL
)
8472 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
8473 strncpy (result
, name
, tmp
- name
);
8474 result
[tmp
- name
] = '\0';
8482 static struct value
*
8483 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
8486 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
8487 (expect_type
, exp
, pos
, noside
);
8490 /* Evaluate the subexpression of EXP starting at *POS as for
8491 evaluate_type, updating *POS to point just past the evaluated
8494 static struct value
*
8495 evaluate_subexp_type (struct expression
*exp
, int *pos
)
8497 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
8498 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8501 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8504 static struct value
*
8505 unwrap_value (struct value
*val
)
8507 struct type
*type
= check_typedef (VALUE_TYPE (val
));
8508 if (ada_is_aligner_type (type
))
8510 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
8511 NULL
, "internal structure");
8512 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
8513 if (ada_type_name (val_type
) == NULL
)
8514 TYPE_NAME (val_type
) = ada_type_name (type
);
8516 return unwrap_value (v
);
8520 struct type
*raw_real_type
=
8521 ada_completed_type (ada_get_base_type (type
));
8523 if (type
== raw_real_type
)
8527 coerce_unspec_val_to_type
8528 (val
, ada_to_fixed_type (raw_real_type
, 0,
8529 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
8534 static struct value
*
8535 cast_to_fixed (struct type
*type
, struct value
*arg
)
8539 if (type
== VALUE_TYPE (arg
))
8541 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
8542 val
= ada_float_to_fixed (type
,
8543 ada_fixed_to_float (VALUE_TYPE (arg
),
8544 value_as_long (arg
)));
8548 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
8549 val
= ada_float_to_fixed (type
, argd
);
8552 return value_from_longest (type
, val
);
8555 static struct value
*
8556 cast_from_fixed_to_double (struct value
*arg
)
8558 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
8559 value_as_long (arg
));
8560 return value_from_double (builtin_type_double
, val
);
8563 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8564 return the converted value. */
8566 static struct value
*
8567 coerce_for_assign (struct type
*type
, struct value
*val
)
8569 struct type
*type2
= VALUE_TYPE (val
);
8573 CHECK_TYPEDEF (type2
);
8574 CHECK_TYPEDEF (type
);
8576 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
8577 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8579 val
= ada_value_ind (val
);
8580 type2
= VALUE_TYPE (val
);
8583 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
8584 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8586 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
8587 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
8588 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
8589 error ("Incompatible types in assignment");
8590 VALUE_TYPE (val
) = type
;
8595 static struct value
*
8596 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
8599 struct type
*type1
, *type2
;
8604 type1
= base_type (check_typedef (VALUE_TYPE (arg1
)));
8605 type2
= base_type (check_typedef (VALUE_TYPE (arg2
)));
8607 if (TYPE_CODE (type1
) != TYPE_CODE_INT
8608 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
8609 return value_binop (arg1
, arg2
, op
);
8618 return value_binop (arg1
, arg2
, op
);
8621 v2
= value_as_long (arg2
);
8623 error ("second operand of %s must not be zero.", op_string (op
));
8625 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
8626 return value_binop (arg1
, arg2
, op
);
8628 v1
= value_as_long (arg1
);
8633 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
8634 v
+= v
> 0 ? -1 : 1;
8642 /* Should not reach this point. */
8646 val
= allocate_value (type1
);
8647 store_unsigned_integer (VALUE_CONTENTS_RAW (val
),
8648 TYPE_LENGTH (VALUE_TYPE (val
)), v
);
8653 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
8655 if (ada_is_direct_array_type (VALUE_TYPE (arg1
))
8656 || ada_is_direct_array_type (VALUE_TYPE (arg2
)))
8658 arg1
= ada_coerce_to_simple_array (arg1
);
8659 arg2
= ada_coerce_to_simple_array (arg2
);
8660 if (TYPE_CODE (VALUE_TYPE (arg1
)) != TYPE_CODE_ARRAY
8661 || TYPE_CODE (VALUE_TYPE (arg2
)) != TYPE_CODE_ARRAY
)
8662 error ("Attempt to compare array with non-array");
8663 /* FIXME: The following works only for types whose
8664 representations use all bits (no padding or undefined bits)
8665 and do not have user-defined equality. */
8667 TYPE_LENGTH (VALUE_TYPE (arg1
)) == TYPE_LENGTH (VALUE_TYPE (arg2
))
8668 && memcmp (VALUE_CONTENTS (arg1
), VALUE_CONTENTS (arg2
),
8669 TYPE_LENGTH (VALUE_TYPE (arg1
))) == 0;
8671 return value_equal (arg1
, arg2
);
8675 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8676 int *pos
, enum noside noside
)
8679 int tem
, tem2
, tem3
;
8681 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8684 struct value
**argvec
;
8688 op
= exp
->elts
[pc
].opcode
;
8695 unwrap_value (evaluate_subexp_standard
8696 (expect_type
, exp
, pos
, noside
));
8700 struct value
*result
;
8702 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8703 /* The result type will have code OP_STRING, bashed there from
8704 OP_ARRAY. Bash it back. */
8705 if (TYPE_CODE (VALUE_TYPE (result
)) == TYPE_CODE_STRING
)
8706 TYPE_CODE (VALUE_TYPE (result
)) = TYPE_CODE_ARRAY
;
8712 type
= exp
->elts
[pc
+ 1].type
;
8713 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8714 if (noside
== EVAL_SKIP
)
8716 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
8718 if (ada_is_fixed_point_type (type
))
8719 arg1
= cast_to_fixed (type
, arg1
);
8720 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8721 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
8722 else if (VALUE_LVAL (arg1
) == lval_memory
)
8724 /* This is in case of the really obscure (and undocumented,
8725 but apparently expected) case of (Foo) Bar.all, where Bar
8726 is an integer constant and Foo is a dynamic-sized type.
8727 If we don't do this, ARG1 will simply be relabeled with
8729 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8730 return value_zero (to_static_fixed_type (type
), not_lval
);
8732 ada_to_fixed_value_create
8733 (type
, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
8736 arg1
= value_cast (type
, arg1
);
8742 type
= exp
->elts
[pc
+ 1].type
;
8743 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8746 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8747 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
8748 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8750 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8751 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
8752 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8754 ("Fixed-point values must be assigned to fixed-point variables");
8756 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
8757 return ada_value_assign (arg1
, arg2
);
8760 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8761 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8762 if (noside
== EVAL_SKIP
)
8764 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
8765 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8766 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
8767 error ("Operands of fixed-point addition must have the same type");
8768 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
8771 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8772 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8773 if (noside
== EVAL_SKIP
)
8775 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
8776 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8777 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
8778 error ("Operands of fixed-point subtraction must have the same type");
8779 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
8783 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8784 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8785 if (noside
== EVAL_SKIP
)
8787 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8788 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8789 return value_zero (VALUE_TYPE (arg1
), not_lval
);
8792 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8793 arg1
= cast_from_fixed_to_double (arg1
);
8794 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8795 arg2
= cast_from_fixed_to_double (arg2
);
8796 return ada_value_binop (arg1
, arg2
, op
);
8801 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8802 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8803 if (noside
== EVAL_SKIP
)
8805 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8806 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8807 return value_zero (VALUE_TYPE (arg1
), not_lval
);
8809 return ada_value_binop (arg1
, arg2
, op
);
8812 case BINOP_NOTEQUAL
:
8813 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8814 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
8815 if (noside
== EVAL_SKIP
)
8817 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8820 tem
= ada_value_equal (arg1
, arg2
);
8821 if (op
== BINOP_NOTEQUAL
)
8823 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
8826 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8827 if (noside
== EVAL_SKIP
)
8829 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8830 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
8832 return value_neg (arg1
);
8836 if (noside
== EVAL_SKIP
)
8841 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8842 /* Only encountered when an unresolved symbol occurs in a
8843 context other than a function call, in which case, it is
8845 error ("Unexpected unresolved symbol, %s, during evaluation",
8846 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8847 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8851 (to_static_fixed_type
8852 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8858 unwrap_value (evaluate_subexp_standard
8859 (expect_type
, exp
, pos
, noside
));
8860 return ada_to_fixed_value (arg1
);
8866 /* Allocate arg vector, including space for the function to be
8867 called in argvec[0] and a terminating NULL. */
8868 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8870 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8872 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8873 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8874 error ("Unexpected unresolved symbol, %s, during evaluation",
8875 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8878 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8879 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8882 if (noside
== EVAL_SKIP
)
8886 if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec
[0]))))
8887 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8888 else if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
8889 || (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_ARRAY
8890 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8891 argvec
[0] = value_addr (argvec
[0]);
8893 type
= check_typedef (VALUE_TYPE (argvec
[0]));
8894 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8896 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
8898 case TYPE_CODE_FUNC
:
8899 type
= check_typedef (TYPE_TARGET_TYPE (type
));
8901 case TYPE_CODE_ARRAY
:
8903 case TYPE_CODE_STRUCT
:
8904 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8905 argvec
[0] = ada_value_ind (argvec
[0]);
8906 type
= check_typedef (TYPE_TARGET_TYPE (type
));
8909 error ("cannot subscript or call something of type `%s'",
8910 ada_type_name (VALUE_TYPE (argvec
[0])));
8915 switch (TYPE_CODE (type
))
8917 case TYPE_CODE_FUNC
:
8918 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8919 return allocate_value (TYPE_TARGET_TYPE (type
));
8920 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8921 case TYPE_CODE_STRUCT
:
8925 /* Make sure to use the parallel ___XVS type if any.
8926 Otherwise, we won't be able to find the array arity
8927 and element type. */
8928 type
= ada_get_base_type (type
);
8930 arity
= ada_array_arity (type
);
8931 type
= ada_array_element_type (type
, nargs
);
8933 error ("cannot subscript or call a record");
8935 error ("wrong number of subscripts; expecting %d", arity
);
8936 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8937 return allocate_value (ada_aligned_type (type
));
8939 unwrap_value (ada_value_subscript
8940 (argvec
[0], nargs
, argvec
+ 1));
8942 case TYPE_CODE_ARRAY
:
8943 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8945 type
= ada_array_element_type (type
, nargs
);
8947 error ("element type of array unknown");
8949 return allocate_value (ada_aligned_type (type
));
8952 unwrap_value (ada_value_subscript
8953 (ada_coerce_to_simple_array (argvec
[0]),
8954 nargs
, argvec
+ 1));
8955 case TYPE_CODE_PTR
: /* Pointer to array */
8956 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8957 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8959 type
= ada_array_element_type (type
, nargs
);
8961 error ("element type of array unknown");
8963 return allocate_value (ada_aligned_type (type
));
8966 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8967 nargs
, argvec
+ 1));
8970 error ("Internal error in evaluate_subexp");
8975 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8976 struct value
*low_bound_val
=
8977 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8978 LONGEST low_bound
= pos_atr (low_bound_val
);
8980 = pos_atr (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
8981 if (noside
== EVAL_SKIP
)
8984 /* If this is a reference type or a pointer type, and
8985 the target type has an XVS parallel type, then get
8986 the real target type. */
8987 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
8988 || TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
)
8989 TYPE_TARGET_TYPE (VALUE_TYPE (array
)) =
8990 ada_get_base_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)));
8992 /* If this is a reference to an aligner type, then remove all
8994 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
8995 && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
))))
8996 TYPE_TARGET_TYPE (VALUE_TYPE (array
)) =
8997 ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)));
8999 if (ada_is_packed_array_type (VALUE_TYPE (array
)))
9000 error ("cannot slice a packed array");
9002 /* If this is a reference to an array or an array lvalue,
9003 convert to a pointer. */
9004 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
9005 || (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_ARRAY
9006 && VALUE_LVAL (array
) == lval_memory
))
9007 array
= value_addr (array
);
9009 if (noside
== EVAL_AVOID_SIDE_EFFECTS
9010 && ada_is_array_descriptor_type
9011 (check_typedef (VALUE_TYPE (array
))))
9013 /* Try dereferencing the array, in case it is an access
9015 struct type
*arrType
= ada_type_of_array (array
, 0);
9016 if (arrType
!= NULL
)
9017 array
= value_at_lazy (arrType
, 0, NULL
);
9020 array
= ada_coerce_to_simple_array_ptr (array
);
9022 /* When EVAL_AVOID_SIDE_EFFECTS, we may get the bounds wrong,
9023 but only in contexts where the value is not being requested
9025 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
)
9027 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9028 return ada_value_ind (array
);
9029 else if (high_bound
< low_bound
)
9030 return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
9034 struct type
*arr_type0
=
9035 to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
9037 struct value
*item0
=
9038 ada_value_ptr_subscript (array
, arr_type0
, 1,
9040 struct value
*slice
=
9041 value_repeat (item0
, high_bound
- low_bound
+ 1);
9042 struct type
*arr_type1
= VALUE_TYPE (slice
);
9043 TYPE_LOW_BOUND (TYPE_INDEX_TYPE (arr_type1
)) = low_bound
;
9044 TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (arr_type1
)) += low_bound
;
9048 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9050 else if (high_bound
< low_bound
)
9051 return empty_array (VALUE_TYPE (array
), low_bound
);
9053 return value_slice (array
, low_bound
, high_bound
- low_bound
+ 1);
9058 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9059 type
= exp
->elts
[pc
+ 1].type
;
9061 if (noside
== EVAL_SKIP
)
9064 switch (TYPE_CODE (type
))
9067 lim_warning ("Membership test incompletely implemented; "
9068 "always returns true", 0);
9069 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
9071 case TYPE_CODE_RANGE
:
9072 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
9073 arg3
= value_from_longest (builtin_type_int
,
9074 TYPE_HIGH_BOUND (type
));
9076 value_from_longest (builtin_type_int
,
9077 (value_less (arg1
, arg3
)
9078 || value_equal (arg1
, arg3
))
9079 && (value_less (arg2
, arg1
)
9080 || value_equal (arg2
, arg1
)));
9083 case BINOP_IN_BOUNDS
:
9085 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9086 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9088 if (noside
== EVAL_SKIP
)
9091 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9092 return value_zero (builtin_type_int
, not_lval
);
9094 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9096 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg2
)))
9097 error ("invalid dimension number to '%s", "range");
9099 arg3
= ada_array_bound (arg2
, tem
, 1);
9100 arg2
= ada_array_bound (arg2
, tem
, 0);
9103 value_from_longest (builtin_type_int
,
9104 (value_less (arg1
, arg3
)
9105 || value_equal (arg1
, arg3
))
9106 && (value_less (arg2
, arg1
)
9107 || value_equal (arg2
, arg1
)));
9109 case TERNOP_IN_RANGE
:
9110 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9111 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9112 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9114 if (noside
== EVAL_SKIP
)
9118 value_from_longest (builtin_type_int
,
9119 (value_less (arg1
, arg3
)
9120 || value_equal (arg1
, arg3
))
9121 && (value_less (arg2
, arg1
)
9122 || value_equal (arg2
, arg1
)));
9128 struct type
*type_arg
;
9129 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9131 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9133 type_arg
= exp
->elts
[pc
+ 2].type
;
9137 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9141 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
9142 error ("illegal operand to '%s", ada_attribute_name (op
));
9143 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
9146 if (noside
== EVAL_SKIP
)
9149 if (type_arg
== NULL
)
9151 arg1
= ada_coerce_ref (arg1
);
9153 if (ada_is_packed_array_type (VALUE_TYPE (arg1
)))
9154 arg1
= ada_coerce_to_simple_array (arg1
);
9156 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg1
)))
9157 error ("invalid dimension number to '%s",
9158 ada_attribute_name (op
));
9160 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9162 type
= ada_index_type (VALUE_TYPE (arg1
), tem
);
9165 ("attempt to take bound of something that is not an array");
9166 return allocate_value (type
);
9171 default: /* Should never happen. */
9172 error ("unexpected attribute encountered");
9174 return ada_array_bound (arg1
, tem
, 0);
9176 return ada_array_bound (arg1
, tem
, 1);
9178 return ada_array_length (arg1
, tem
);
9181 else if (discrete_type_p (type_arg
))
9183 struct type
*range_type
;
9184 char *name
= ada_type_name (type_arg
);
9186 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
9188 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
9189 if (range_type
== NULL
)
9190 range_type
= type_arg
;
9194 error ("unexpected attribute encountered");
9196 return discrete_type_low_bound (range_type
);
9198 return discrete_type_high_bound (range_type
);
9200 error ("the 'length attribute applies only to array types");
9203 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
9204 error ("unimplemented type attribute");
9209 if (ada_is_packed_array_type (type_arg
))
9210 type_arg
= decode_packed_array_type (type_arg
);
9212 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
9213 error ("invalid dimension number to '%s",
9214 ada_attribute_name (op
));
9216 type
= ada_index_type (type_arg
, tem
);
9219 ("attempt to take bound of something that is not an array");
9220 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9221 return allocate_value (type
);
9226 error ("unexpected attribute encountered");
9228 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9229 return value_from_longest (type
, low
);
9231 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
9232 return value_from_longest (type
, high
);
9234 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9235 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
9236 return value_from_longest (type
, high
- low
+ 1);
9242 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9243 if (noside
== EVAL_SKIP
)
9246 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9247 return value_zero (ada_tag_type (arg1
), not_lval
);
9249 return ada_value_tag (arg1
);
9253 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9254 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9255 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9256 if (noside
== EVAL_SKIP
)
9258 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9259 return value_zero (VALUE_TYPE (arg1
), not_lval
);
9261 return value_binop (arg1
, arg2
,
9262 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9264 case OP_ATR_MODULUS
:
9266 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
9267 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9269 if (noside
== EVAL_SKIP
)
9272 if (!ada_is_modular_type (type_arg
))
9273 error ("'modulus must be applied to modular type");
9275 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9276 ada_modulus (type_arg
));
9281 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9282 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9283 if (noside
== EVAL_SKIP
)
9285 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9286 return value_zero (builtin_type_ada_int
, not_lval
);
9288 return value_pos_atr (arg1
);
9291 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9292 if (noside
== EVAL_SKIP
)
9294 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9295 return value_zero (builtin_type_ada_int
, not_lval
);
9297 return value_from_longest (builtin_type_ada_int
,
9299 * TYPE_LENGTH (VALUE_TYPE (arg1
)));
9302 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9303 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9304 type
= exp
->elts
[pc
+ 2].type
;
9305 if (noside
== EVAL_SKIP
)
9307 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9308 return value_zero (type
, not_lval
);
9310 return value_val_atr (type
, arg1
);
9313 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9314 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9315 if (noside
== EVAL_SKIP
)
9317 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9318 return value_zero (VALUE_TYPE (arg1
), not_lval
);
9320 return value_binop (arg1
, arg2
, op
);
9323 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9324 if (noside
== EVAL_SKIP
)
9330 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9331 if (noside
== EVAL_SKIP
)
9333 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
9334 return value_neg (arg1
);
9339 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
9340 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
9341 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
9342 if (noside
== EVAL_SKIP
)
9344 type
= check_typedef (VALUE_TYPE (arg1
));
9345 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9347 if (ada_is_array_descriptor_type (type
))
9348 /* GDB allows dereferencing GNAT array descriptors. */
9350 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9351 if (arrType
== NULL
)
9352 error ("Attempt to dereference null array pointer.");
9353 return value_at_lazy (arrType
, 0, NULL
);
9355 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9356 || TYPE_CODE (type
) == TYPE_CODE_REF
9357 /* In C you can dereference an array to get the 1st elt. */
9358 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9361 (to_static_fixed_type
9362 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
9364 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9365 /* GDB allows dereferencing an int. */
9366 return value_zero (builtin_type_int
, lval_memory
);
9368 error ("Attempt to take contents of a non-pointer value.");
9370 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9371 type
= check_typedef (VALUE_TYPE (arg1
));
9373 if (ada_is_array_descriptor_type (type
))
9374 /* GDB allows dereferencing GNAT array descriptors. */
9375 return ada_coerce_to_simple_array (arg1
);
9377 return ada_value_ind (arg1
);
9379 case STRUCTOP_STRUCT
:
9380 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9381 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9382 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9383 if (noside
== EVAL_SKIP
)
9385 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9387 struct type
*type1
= VALUE_TYPE (arg1
);
9388 if (ada_is_tagged_type (type1
, 1))
9390 type
= ada_lookup_struct_elt_type (type1
,
9391 &exp
->elts
[pc
+ 2].string
,
9394 /* In this case, we assume that the field COULD exist
9395 in some extension of the type. Return an object of
9396 "type" void, which will match any formal
9397 (see ada_type_match). */
9398 return value_zero (builtin_type_void
, lval_memory
);
9402 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9405 return value_zero (ada_aligned_type (type
), lval_memory
);
9409 ada_to_fixed_value (unwrap_value
9410 (ada_value_struct_elt
9411 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
9413 /* The value is not supposed to be used. This is here to make it
9414 easier to accommodate expressions that contain types. */
9416 if (noside
== EVAL_SKIP
)
9418 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9419 return allocate_value (builtin_type_void
);
9421 error ("Attempt to use a type name as an expression");
9425 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
9431 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9432 type name that encodes the 'small and 'delta information.
9433 Otherwise, return NULL. */
9436 fixed_type_info (struct type
*type
)
9438 const char *name
= ada_type_name (type
);
9439 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9441 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9443 const char *tail
= strstr (name
, "___XF_");
9449 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9450 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9455 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9458 ada_is_fixed_point_type (struct type
*type
)
9460 return fixed_type_info (type
) != NULL
;
9463 /* Return non-zero iff TYPE represents a System.Address type. */
9466 ada_is_system_address_type (struct type
*type
)
9468 return (TYPE_NAME (type
)
9469 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9472 /* Assuming that TYPE is the representation of an Ada fixed-point
9473 type, return its delta, or -1 if the type is malformed and the
9474 delta cannot be determined. */
9477 ada_delta (struct type
*type
)
9479 const char *encoding
= fixed_type_info (type
);
9482 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
9485 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
9488 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9489 factor ('SMALL value) associated with the type. */
9492 scaling_factor (struct type
*type
)
9494 const char *encoding
= fixed_type_info (type
);
9495 unsigned long num0
, den0
, num1
, den1
;
9498 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
9503 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
9505 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
9509 /* Assuming that X is the representation of a value of fixed-point
9510 type TYPE, return its floating-point equivalent. */
9513 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9515 return (DOUBLEST
) x
*scaling_factor (type
);
9518 /* The representation of a fixed-point value of type TYPE
9519 corresponding to the value X. */
9522 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9524 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9528 /* VAX floating formats */
9530 /* Non-zero iff TYPE represents one of the special VAX floating-point
9534 ada_is_vax_floating_type (struct type
*type
)
9537 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
9540 && (TYPE_CODE (type
) == TYPE_CODE_INT
9541 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9542 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
9545 /* The type of special VAX floating-point type this is, assuming
9546 ada_is_vax_floating_point. */
9549 ada_vax_float_type_suffix (struct type
*type
)
9551 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
9554 /* A value representing the special debugging function that outputs
9555 VAX floating-point values of the type represented by TYPE. Assumes
9556 ada_is_vax_floating_type (TYPE). */
9559 ada_vax_float_print_function (struct type
*type
)
9561 switch (ada_vax_float_type_suffix (type
))
9564 return get_var_value ("DEBUG_STRING_F", 0);
9566 return get_var_value ("DEBUG_STRING_D", 0);
9568 return get_var_value ("DEBUG_STRING_G", 0);
9570 error ("invalid VAX floating-point type");
9577 /* Scan STR beginning at position K for a discriminant name, and
9578 return the value of that discriminant field of DVAL in *PX. If
9579 PNEW_K is not null, put the position of the character beyond the
9580 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9581 not alter *PX and *PNEW_K if unsuccessful. */
9584 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9587 static char *bound_buffer
= NULL
;
9588 static size_t bound_buffer_len
= 0;
9591 struct value
*bound_val
;
9593 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9596 pend
= strstr (str
+ k
, "__");
9600 k
+= strlen (bound
);
9604 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9605 bound
= bound_buffer
;
9606 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9607 bound
[pend
- (str
+ k
)] = '\0';
9611 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
9612 if (bound_val
== NULL
)
9615 *px
= value_as_long (bound_val
);
9621 /* Value of variable named NAME in the current environment. If
9622 no such variable found, then if ERR_MSG is null, returns 0, and
9623 otherwise causes an error with message ERR_MSG. */
9625 static struct value
*
9626 get_var_value (char *name
, char *err_msg
)
9628 struct ada_symbol_info
*syms
;
9631 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9636 if (err_msg
== NULL
)
9639 error ("%s", err_msg
);
9642 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9645 /* Value of integer variable named NAME in the current environment. If
9646 no such variable found, returns 0, and sets *FLAG to 0. If
9647 successful, sets *FLAG to 1. */
9650 get_int_var_value (char *name
, int *flag
)
9652 struct value
*var_val
= get_var_value (name
, 0);
9664 return value_as_long (var_val
);
9669 /* Return a range type whose base type is that of the range type named
9670 NAME in the current environment, and whose bounds are calculated
9671 from NAME according to the GNAT range encoding conventions.
9672 Extract discriminant values, if needed, from DVAL. If a new type
9673 must be created, allocate in OBJFILE's space. The bounds
9674 information, in general, is encoded in NAME, the base type given in
9675 the named range type. */
9677 static struct type
*
9678 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9680 struct type
*raw_type
= ada_find_any_type (name
);
9681 struct type
*base_type
;
9684 if (raw_type
== NULL
)
9685 base_type
= builtin_type_int
;
9686 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9687 base_type
= TYPE_TARGET_TYPE (raw_type
);
9689 base_type
= raw_type
;
9691 subtype_info
= strstr (name
, "___XD");
9692 if (subtype_info
== NULL
)
9696 static char *name_buf
= NULL
;
9697 static size_t name_len
= 0;
9698 int prefix_len
= subtype_info
- name
;
9704 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9705 strncpy (name_buf
, name
, prefix_len
);
9706 name_buf
[prefix_len
] = '\0';
9709 bounds_str
= strchr (subtype_info
, '_');
9712 if (*subtype_info
== 'L')
9714 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9715 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9717 if (bounds_str
[n
] == '_')
9719 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9726 strcpy (name_buf
+ prefix_len
, "___L");
9727 L
= get_int_var_value (name_buf
, &ok
);
9730 lim_warning ("Unknown lower bound, using 1.", 1);
9735 if (*subtype_info
== 'U')
9737 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9738 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9744 strcpy (name_buf
+ prefix_len
, "___U");
9745 U
= get_int_var_value (name_buf
, &ok
);
9748 lim_warning ("Unknown upper bound, using %ld.", (long) L
);
9753 if (objfile
== NULL
)
9754 objfile
= TYPE_OBJFILE (base_type
);
9755 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9756 TYPE_NAME (type
) = name
;
9761 /* True iff NAME is the name of a range type. */
9764 ada_is_range_type_name (const char *name
)
9766 return (name
!= NULL
&& strstr (name
, "___XD"));
9772 /* True iff TYPE is an Ada modular type. */
9775 ada_is_modular_type (struct type
*type
)
9777 struct type
*subranged_type
= base_type (type
);
9779 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9780 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
9781 && TYPE_UNSIGNED (subranged_type
));
9784 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9787 ada_modulus (struct type
* type
)
9789 return TYPE_HIGH_BOUND (type
) + 1;
9793 /* Information about operators given special treatment in functions
9795 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
9797 #define ADA_OPERATORS \
9798 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
9799 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
9800 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
9801 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
9802 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
9803 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
9804 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
9805 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
9806 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
9807 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
9808 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
9809 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
9810 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
9811 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
9812 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
9813 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
9816 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
9818 switch (exp
->elts
[pc
- 1].opcode
)
9821 operator_length_standard (exp
, pc
, oplenp
, argsp
);
9824 #define OP_DEFN(op, len, args, binop) \
9825 case op: *oplenp = len; *argsp = args; break;
9832 ada_op_name (enum exp_opcode opcode
)
9837 return op_name_standard (opcode
);
9838 #define OP_DEFN(op, len, args, binop) case op: return #op;
9844 /* As for operator_length, but assumes PC is pointing at the first
9845 element of the operator, and gives meaningful results only for the
9846 Ada-specific operators. */
9849 ada_forward_operator_length (struct expression
*exp
, int pc
,
9850 int *oplenp
, int *argsp
)
9852 switch (exp
->elts
[pc
].opcode
)
9855 *oplenp
= *argsp
= 0;
9857 #define OP_DEFN(op, len, args, binop) \
9858 case op: *oplenp = len; *argsp = args; break;
9865 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
9867 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
9872 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
9876 /* Ada attributes ('Foo). */
9883 case OP_ATR_MODULUS
:
9892 fprintf_filtered (stream
, "Type @");
9893 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
9894 fprintf_filtered (stream
, " (");
9895 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
9896 fprintf_filtered (stream
, ")");
9898 case BINOP_IN_BOUNDS
:
9899 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
9901 case TERNOP_IN_RANGE
:
9905 return dump_subexp_body_standard (exp
, stream
, elt
);
9909 for (i
= 0; i
< nargs
; i
+= 1)
9910 elt
= dump_subexp (exp
, stream
, elt
);
9915 /* The Ada extension of print_subexp (q.v.). */
9918 ada_print_subexp (struct expression
*exp
, int *pos
,
9919 struct ui_file
*stream
, enum precedence prec
)
9923 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
9925 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9930 print_subexp_standard (exp
, pos
, stream
, prec
);
9935 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
9938 case BINOP_IN_BOUNDS
:
9940 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9941 fputs_filtered (" in ", stream
);
9942 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9943 fputs_filtered ("'range", stream
);
9944 if (exp
->elts
[pc
+ 1].longconst
> 1)
9945 fprintf_filtered (stream
, "(%ld)",
9946 (long) exp
->elts
[pc
+ 1].longconst
);
9949 case TERNOP_IN_RANGE
:
9951 if (prec
>= PREC_EQUAL
)
9952 fputs_filtered ("(", stream
);
9953 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9954 fputs_filtered (" in ", stream
);
9955 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
9956 fputs_filtered (" .. ", stream
);
9957 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
9958 if (prec
>= PREC_EQUAL
)
9959 fputs_filtered (")", stream
);
9968 case OP_ATR_MODULUS
:
9974 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9976 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
9977 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
9981 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9982 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
9986 for (tem
= 1; tem
< nargs
; tem
+= 1)
9988 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
9989 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
9991 fputs_filtered (")", stream
);
9997 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
9998 fputs_filtered ("'(", stream
);
9999 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
10000 fputs_filtered (")", stream
);
10003 case UNOP_IN_RANGE
:
10005 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10006 fputs_filtered (" in ", stream
);
10007 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10012 /* Table mapping opcodes into strings for printing operators
10013 and precedences of the operators. */
10015 static const struct op_print ada_op_print_tab
[] = {
10016 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10017 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10018 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10019 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10020 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10021 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10022 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10023 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10024 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10025 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10026 {">", BINOP_GTR
, PREC_ORDER
, 0},
10027 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10028 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10029 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10030 {"+", BINOP_ADD
, PREC_ADD
, 0},
10031 {"-", BINOP_SUB
, PREC_ADD
, 0},
10032 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10033 {"*", BINOP_MUL
, PREC_MUL
, 0},
10034 {"/", BINOP_DIV
, PREC_MUL
, 0},
10035 {"rem", BINOP_REM
, PREC_MUL
, 0},
10036 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10037 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10038 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10039 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10040 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10041 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10042 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10043 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10044 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10045 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10046 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10050 /* Assorted Types and Interfaces */
10052 struct type
*builtin_type_ada_int
;
10053 struct type
*builtin_type_ada_short
;
10054 struct type
*builtin_type_ada_long
;
10055 struct type
*builtin_type_ada_long_long
;
10056 struct type
*builtin_type_ada_char
;
10057 struct type
*builtin_type_ada_float
;
10058 struct type
*builtin_type_ada_double
;
10059 struct type
*builtin_type_ada_long_double
;
10060 struct type
*builtin_type_ada_natural
;
10061 struct type
*builtin_type_ada_positive
;
10062 struct type
*builtin_type_ada_system_address
;
10064 struct type
**const (ada_builtin_types
[]) =
10066 &builtin_type_ada_int
,
10067 &builtin_type_ada_long
,
10068 &builtin_type_ada_short
,
10069 &builtin_type_ada_char
,
10070 &builtin_type_ada_float
,
10071 &builtin_type_ada_double
,
10072 &builtin_type_ada_long_long
,
10073 &builtin_type_ada_long_double
,
10074 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
10075 /* The following types are carried over from C for convenience. */
10077 &builtin_type_long
,
10078 &builtin_type_short
,
10079 &builtin_type_char
,
10080 &builtin_type_float
,
10081 &builtin_type_double
,
10082 &builtin_type_long_long
,
10083 &builtin_type_void
,
10084 &builtin_type_signed_char
,
10085 &builtin_type_unsigned_char
,
10086 &builtin_type_unsigned_short
,
10087 &builtin_type_unsigned_int
,
10088 &builtin_type_unsigned_long
,
10089 &builtin_type_unsigned_long_long
,
10090 &builtin_type_long_double
,
10091 &builtin_type_complex
, &builtin_type_double_complex
, 0};
10093 /* Not really used, but needed in the ada_language_defn. */
10096 emit_char (int c
, struct ui_file
*stream
, int quoter
)
10098 ada_emit_char (c
, stream
, quoter
, 1);
10104 warnings_issued
= 0;
10105 return ada_parse ();
10108 static const struct exp_descriptor ada_exp_descriptor
= {
10110 ada_operator_length
,
10112 ada_dump_subexp_body
,
10113 ada_evaluate_subexp
10116 const struct language_defn ada_language_defn
= {
10117 "ada", /* Language name */
10122 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
10123 that's not quite what this means. */
10126 ada_lookup_minimal_symbol
,
10127 #endif /* GNAT_GDB */
10128 &ada_exp_descriptor
,
10132 ada_printchar
, /* Print a character constant */
10133 ada_printstr
, /* Function to print string constant */
10134 emit_char
, /* Function to print single char (not used) */
10135 ada_create_fundamental_type
, /* Create fundamental type in this language */
10136 ada_print_type
, /* Print a type using appropriate syntax */
10137 ada_val_print
, /* Print a value using appropriate syntax */
10138 ada_value_print
, /* Print a top-level value */
10139 NULL
, /* Language specific skip_trampoline */
10140 NULL
, /* value_of_this */
10141 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
10142 basic_lookup_transparent_type
, /* lookup_transparent_type */
10143 ada_la_decode
, /* Language specific symbol demangler */
10144 {"", "", "", ""}, /* Binary format info */
10146 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
10147 {"%ld", "", "d", ""}, /* Decimal format info */
10148 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
10150 /* Copied from c-lang.c. */
10151 {"0%lo", "0", "o", ""}, /* Octal format info */
10152 {"%ld", "", "d", ""}, /* Decimal format info */
10153 {"0x%lx", "0x", "x", ""}, /* Hex format info */
10155 ada_op_print_tab
, /* expression operators for printing */
10156 0, /* c-style arrays */
10157 1, /* String lower bound */
10158 &builtin_type_ada_char
,
10159 ada_get_gdb_completer_word_break_characters
,
10161 ada_translate_error_message
, /* Substitute Ada-specific terminology
10162 in errors and warnings. */
10163 #endif /* GNAT_GDB */
10168 build_ada_types (void)
10170 builtin_type_ada_int
=
10171 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10172 0, "integer", (struct objfile
*) NULL
);
10173 builtin_type_ada_long
=
10174 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10175 0, "long_integer", (struct objfile
*) NULL
);
10176 builtin_type_ada_short
=
10177 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10178 0, "short_integer", (struct objfile
*) NULL
);
10179 builtin_type_ada_char
=
10180 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10181 0, "character", (struct objfile
*) NULL
);
10182 builtin_type_ada_float
=
10183 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
10184 0, "float", (struct objfile
*) NULL
);
10185 builtin_type_ada_double
=
10186 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10187 0, "long_float", (struct objfile
*) NULL
);
10188 builtin_type_ada_long_long
=
10189 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10190 0, "long_long_integer", (struct objfile
*) NULL
);
10191 builtin_type_ada_long_double
=
10192 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10193 0, "long_long_float", (struct objfile
*) NULL
);
10194 builtin_type_ada_natural
=
10195 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10196 0, "natural", (struct objfile
*) NULL
);
10197 builtin_type_ada_positive
=
10198 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10199 0, "positive", (struct objfile
*) NULL
);
10202 builtin_type_ada_system_address
=
10203 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10204 (struct objfile
*) NULL
));
10205 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
10209 _initialize_ada_language (void)
10212 build_ada_types ();
10213 deprecated_register_gdbarch_swap (NULL
, 0, build_ada_types
);
10214 add_language (&ada_language_defn
);
10216 varsize_limit
= 65536;
10219 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
10220 (char *) &varsize_limit
,
10221 "Set maximum bytes in dynamic-sized object.",
10222 &setlist
), &showlist
);
10223 obstack_init (&cache_space
);
10224 #endif /* GNAT_GDB */
10226 obstack_init (&symbol_list_obstack
);
10228 decoded_names_store
= htab_create_alloc_ex
10229 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
10230 NULL
, NULL
, xmcalloc
, xmfree
);
10233 /* Create a fundamental Ada type using default reasonable for the current
10236 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
10237 define fundamental types such as "int" or "double". Others (stabs or
10238 DWARF version 2, etc) do define fundamental types. For the formats which
10239 don't provide fundamental types, gdb can create such types using this
10242 FIXME: Some compilers distinguish explicitly signed integral types
10243 (signed short, signed int, signed long) from "regular" integral types
10244 (short, int, long) in the debugging information. There is some dis-
10245 agreement as to how useful this feature is. In particular, gcc does
10246 not support this. Also, only some debugging formats allow the
10247 distinction to be passed on to a debugger. For now, we always just
10248 use "short", "int", or "long" as the type name, for both the implicit
10249 and explicitly signed types. This also makes life easier for the
10250 gdb test suite since we don't have to account for the differences
10251 in output depending upon what the compiler and debugging format
10252 support. We will probably have to re-examine the issue when gdb
10253 starts taking it's fundamental type information directly from the
10254 debugging information supplied by the compiler. fnf@cygnus.com */
10256 static struct type
*
10257 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
10259 struct type
*type
= NULL
;
10264 /* FIXME: For now, if we are asked to produce a type not in this
10265 language, create the equivalent of a C integer type with the
10266 name "<?type?>". When all the dust settles from the type
10267 reconstruction work, this should probably become an error. */
10268 type
= init_type (TYPE_CODE_INT
,
10269 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10270 0, "<?type?>", objfile
);
10271 warning ("internal error: no Ada fundamental type %d", typeid);
10274 type
= init_type (TYPE_CODE_VOID
,
10275 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10276 0, "void", objfile
);
10279 type
= init_type (TYPE_CODE_INT
,
10280 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10281 0, "character", objfile
);
10283 case FT_SIGNED_CHAR
:
10284 type
= init_type (TYPE_CODE_INT
,
10285 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10286 0, "signed char", objfile
);
10288 case FT_UNSIGNED_CHAR
:
10289 type
= init_type (TYPE_CODE_INT
,
10290 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10291 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
10294 type
= init_type (TYPE_CODE_INT
,
10295 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10296 0, "short_integer", objfile
);
10298 case FT_SIGNED_SHORT
:
10299 type
= init_type (TYPE_CODE_INT
,
10300 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10301 0, "short_integer", objfile
);
10303 case FT_UNSIGNED_SHORT
:
10304 type
= init_type (TYPE_CODE_INT
,
10305 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10306 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
10309 type
= init_type (TYPE_CODE_INT
,
10310 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10311 0, "integer", objfile
);
10313 case FT_SIGNED_INTEGER
:
10314 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
10316 case FT_UNSIGNED_INTEGER
:
10317 type
= init_type (TYPE_CODE_INT
,
10318 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10319 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
10322 type
= init_type (TYPE_CODE_INT
,
10323 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10324 0, "long_integer", objfile
);
10326 case FT_SIGNED_LONG
:
10327 type
= init_type (TYPE_CODE_INT
,
10328 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10329 0, "long_integer", objfile
);
10331 case FT_UNSIGNED_LONG
:
10332 type
= init_type (TYPE_CODE_INT
,
10333 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10334 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
10337 type
= init_type (TYPE_CODE_INT
,
10338 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10339 0, "long_long_integer", objfile
);
10341 case FT_SIGNED_LONG_LONG
:
10342 type
= init_type (TYPE_CODE_INT
,
10343 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10344 0, "long_long_integer", objfile
);
10346 case FT_UNSIGNED_LONG_LONG
:
10347 type
= init_type (TYPE_CODE_INT
,
10348 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10349 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
10352 type
= init_type (TYPE_CODE_FLT
,
10353 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
10354 0, "float", objfile
);
10356 case FT_DBL_PREC_FLOAT
:
10357 type
= init_type (TYPE_CODE_FLT
,
10358 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10359 0, "long_float", objfile
);
10361 case FT_EXT_PREC_FLOAT
:
10362 type
= init_type (TYPE_CODE_FLT
,
10363 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10364 0, "long_long_float", objfile
);
10371 ada_dump_symtab (struct symtab
*s
)
10374 fprintf (stderr
, "New symtab: [\n");
10375 fprintf (stderr
, " Name: %s/%s;\n",
10376 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
10377 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
10378 if (s
->linetable
!= NULL
)
10380 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
10381 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
10383 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
10384 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
10387 fprintf (stderr
, "]\n");