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 as Linux]
4759 ___[0-9]+ [nested subprogram suffix, on platforms such as HP/UX]
4760 (X[nb]*)?((\$|__)[0-9](_?[0-9]+)|___(LJM|X([FDBUP].*|R[^T]?)))?$
4764 is_name_suffix (const char *str
)
4767 const char *matching
;
4768 const int len
= strlen (str
);
4770 /* (__[0-9]+)?\.[0-9]+ */
4772 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && isdigit (str
[2]))
4775 while (isdigit (matching
[0]))
4777 if (matching
[0] == '\0')
4781 if (matching
[0] == '.')
4784 while (isdigit (matching
[0]))
4786 if (matching
[0] == '\0')
4791 if (len
> 3 && str
[0] == '_' && str
[1] == '_' && str
[2] == '_')
4794 while (isdigit (matching
[0]))
4796 if (matching
[0] == '\0')
4800 /* ??? We should not modify STR directly, as we are doing below. This
4801 is fine in this case, but may become problematic later if we find
4802 that this alternative did not work, and want to try matching
4803 another one from the begining of STR. Since we modified it, we
4804 won't be able to find the begining of the string anymore! */
4808 while (str
[0] != '_' && str
[0] != '\0')
4810 if (str
[0] != 'n' && str
[0] != 'b')
4815 if (str
[0] == '\000')
4819 if (str
[1] != '_' || str
[2] == '\000')
4823 if (strcmp (str
+ 3, "LJM") == 0)
4827 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B'
4828 || str
[4] == 'U' || str
[4] == 'P')
4830 if (str
[4] == 'R' && str
[5] != 'T')
4834 if (!isdigit (str
[2]))
4836 for (k
= 3; str
[k
] != '\0'; k
+= 1)
4837 if (!isdigit (str
[k
]) && str
[k
] != '_')
4841 if (str
[0] == '$' && isdigit (str
[1]))
4843 for (k
= 2; str
[k
] != '\0'; k
+= 1)
4844 if (!isdigit (str
[k
]) && str
[k
] != '_')
4851 /* Return nonzero if the given string starts with a dot ('.')
4852 followed by zero or more digits.
4854 Note: brobecker/2003-11-10: A forward declaration has not been
4855 added at the begining of this file yet, because this function
4856 is only used to work around a problem found during wild matching
4857 when trying to match minimal symbol names against symbol names
4858 obtained from dwarf-2 data. This function is therefore currently
4859 only used in wild_match() and is likely to be deleted when the
4860 problem in dwarf-2 is fixed. */
4863 is_dot_digits_suffix (const char *str
)
4869 while (isdigit (str
[0]))
4871 return (str
[0] == '\0');
4874 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
4875 PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
4876 informational suffixes of NAME (i.e., for which is_name_suffix is
4880 wild_match (const char *patn0
, int patn_len
, const char *name0
)
4886 /* FIXME: brobecker/2003-11-10: For some reason, the symbol name
4887 stored in the symbol table for nested function names is sometimes
4888 different from the name of the associated entity stored in
4889 the dwarf-2 data: This is the case for nested subprograms, where
4890 the minimal symbol name contains a trailing ".[:digit:]+" suffix,
4891 while the symbol name from the dwarf-2 data does not.
4893 Although the DWARF-2 standard documents that entity names stored
4894 in the dwarf-2 data should be identical to the name as seen in
4895 the source code, GNAT takes a different approach as we already use
4896 a special encoding mechanism to convey the information so that
4897 a C debugger can still use the information generated to debug
4898 Ada programs. A corollary is that the symbol names in the dwarf-2
4899 data should match the names found in the symbol table. I therefore
4900 consider this issue as a compiler defect.
4902 Until the compiler is properly fixed, we work-around the problem
4903 by ignoring such suffixes during the match. We do so by making
4904 a copy of PATN0 and NAME0, and then by stripping such a suffix
4905 if present. We then perform the match on the resulting strings. */
4908 name_len
= strlen (name0
);
4910 name
= (char *) alloca ((name_len
+ 1) * sizeof (char));
4911 strcpy (name
, name0
);
4912 dot
= strrchr (name
, '.');
4913 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4916 patn
= (char *) alloca ((patn_len
+ 1) * sizeof (char));
4917 strncpy (patn
, patn0
, patn_len
);
4918 patn
[patn_len
] = '\0';
4919 dot
= strrchr (patn
, '.');
4920 if (dot
!= NULL
&& is_dot_digits_suffix (dot
))
4923 patn_len
= dot
- patn
;
4927 /* Now perform the wild match. */
4929 name_len
= strlen (name
);
4930 if (name_len
>= patn_len
+ 5 && strncmp (name
, "_ada_", 5) == 0
4931 && strncmp (patn
, name
+ 5, patn_len
) == 0
4932 && is_name_suffix (name
+ patn_len
+ 5))
4935 while (name_len
>= patn_len
)
4937 if (strncmp (patn
, name
, patn_len
) == 0
4938 && is_name_suffix (name
+ patn_len
))
4946 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
4951 if (!islower (name
[2]))
4958 if (!islower (name
[1]))
4969 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
4970 vector *defn_symbols, updating the list of symbols in OBSTACKP
4971 (if necessary). If WILD, treat as NAME with a wildcard prefix.
4972 OBJFILE is the section containing BLOCK.
4973 SYMTAB is recorded with each symbol added. */
4976 ada_add_block_symbols (struct obstack
*obstackp
,
4977 struct block
*block
, const char *name
,
4978 domain_enum domain
, struct objfile
*objfile
,
4979 struct symtab
*symtab
, int wild
)
4981 struct dict_iterator iter
;
4982 int name_len
= strlen (name
);
4983 /* A matching argument symbol, if any. */
4984 struct symbol
*arg_sym
;
4985 /* Set true when we find a matching non-argument symbol. */
4994 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
4996 if (SYMBOL_DOMAIN (sym
) == domain
4997 && wild_match (name
, name_len
, SYMBOL_LINKAGE_NAME (sym
)))
4999 switch (SYMBOL_CLASS (sym
))
5005 case LOC_REGPARM_ADDR
:
5006 case LOC_BASEREG_ARG
:
5007 case LOC_COMPUTED_ARG
:
5010 case LOC_UNRESOLVED
:
5014 add_defn_to_vec (obstackp
,
5015 fixup_symbol_section (sym
, objfile
),
5024 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5026 if (SYMBOL_DOMAIN (sym
) == domain
)
5028 int cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
), name_len
);
5030 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
))
5032 switch (SYMBOL_CLASS (sym
))
5038 case LOC_REGPARM_ADDR
:
5039 case LOC_BASEREG_ARG
:
5040 case LOC_COMPUTED_ARG
:
5043 case LOC_UNRESOLVED
:
5047 add_defn_to_vec (obstackp
,
5048 fixup_symbol_section (sym
, objfile
),
5057 if (!found_sym
&& arg_sym
!= NULL
)
5059 add_defn_to_vec (obstackp
,
5060 fixup_symbol_section (arg_sym
, objfile
),
5069 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
5071 if (SYMBOL_DOMAIN (sym
) == domain
)
5075 cmp
= (int) '_' - (int) SYMBOL_LINKAGE_NAME (sym
)[0];
5078 cmp
= strncmp ("_ada_", SYMBOL_LINKAGE_NAME (sym
), 5);
5080 cmp
= strncmp (name
, SYMBOL_LINKAGE_NAME (sym
) + 5,
5085 && is_name_suffix (SYMBOL_LINKAGE_NAME (sym
) + name_len
+ 5))
5087 switch (SYMBOL_CLASS (sym
))
5093 case LOC_REGPARM_ADDR
:
5094 case LOC_BASEREG_ARG
:
5095 case LOC_COMPUTED_ARG
:
5098 case LOC_UNRESOLVED
:
5102 add_defn_to_vec (obstackp
,
5103 fixup_symbol_section (sym
, objfile
),
5112 /* NOTE: This really shouldn't be needed for _ada_ symbols.
5113 They aren't parameters, right? */
5114 if (!found_sym
&& arg_sym
!= NULL
)
5116 add_defn_to_vec (obstackp
,
5117 fixup_symbol_section (arg_sym
, objfile
),
5125 /* Symbol Completion */
5127 /* If SYM_NAME is a completion candidate for TEXT, return this symbol
5128 name in a form that's appropriate for the completion. The result
5129 does not need to be deallocated, but is only good until the next call.
5131 TEXT_LEN is equal to the length of TEXT.
5132 Perform a wild match if WILD_MATCH is set.
5133 ENCODED should be set if TEXT represents the start of a symbol name
5134 in its encoded form. */
5137 symbol_completion_match (const char *sym_name
,
5138 const char *text
, int text_len
,
5139 int wild_match
, int encoded
)
5142 const int verbatim_match
= (text
[0] == '<');
5147 /* Strip the leading angle bracket. */
5152 /* First, test against the fully qualified name of the symbol. */
5154 if (strncmp (sym_name
, text
, text_len
) == 0)
5157 if (match
&& !encoded
)
5159 /* One needed check before declaring a positive match is to verify
5160 that iff we are doing a verbatim match, the decoded version
5161 of the symbol name starts with '<'. Otherwise, this symbol name
5162 is not a suitable completion. */
5163 const char *sym_name_copy
= sym_name
;
5164 int has_angle_bracket
;
5166 sym_name
= ada_decode (sym_name
);
5167 has_angle_bracket
= (sym_name
[0] == '<');
5168 match
= (has_angle_bracket
== verbatim_match
);
5169 sym_name
= sym_name_copy
;
5172 if (match
&& !verbatim_match
)
5174 /* When doing non-verbatim match, another check that needs to
5175 be done is to verify that the potentially matching symbol name
5176 does not include capital letters, because the ada-mode would
5177 not be able to understand these symbol names without the
5178 angle bracket notation. */
5181 for (tmp
= sym_name
; *tmp
!= '\0' && !isupper (*tmp
); tmp
++);
5186 /* Second: Try wild matching... */
5188 if (!match
&& wild_match
)
5190 /* Since we are doing wild matching, this means that TEXT
5191 may represent an unqualified symbol name. We therefore must
5192 also compare TEXT against the unqualified name of the symbol. */
5193 sym_name
= ada_unqualified_name (ada_decode (sym_name
));
5195 if (strncmp (sym_name
, text
, text_len
) == 0)
5199 /* Finally: If we found a mach, prepare the result to return. */
5205 sym_name
= add_angle_brackets (sym_name
);
5208 sym_name
= ada_decode (sym_name
);
5213 /* A companion function to ada_make_symbol_completion_list().
5214 Check if SYM_NAME represents a symbol which name would be suitable
5215 to complete TEXT (TEXT_LEN is the length of TEXT), in which case
5216 it is appended at the end of the given string vector SV.
5218 ORIG_TEXT is the string original string from the user command
5219 that needs to be completed. WORD is the entire command on which
5220 completion should be performed. These two parameters are used to
5221 determine which part of the symbol name should be added to the
5223 if WILD_MATCH is set, then wild matching is performed.
5224 ENCODED should be set if TEXT represents a symbol name in its
5225 encoded formed (in which case the completion should also be
5229 symbol_completion_add (struct string_vector
*sv
,
5230 const char *sym_name
,
5231 const char *text
, int text_len
,
5232 const char *orig_text
, const char *word
,
5233 int wild_match
, int encoded
)
5235 const char *match
= symbol_completion_match (sym_name
, text
, text_len
,
5236 wild_match
, encoded
);
5242 /* We found a match, so add the appropriate completion to the given
5245 if (word
== orig_text
)
5247 completion
= xmalloc (strlen (match
) + 5);
5248 strcpy (completion
, match
);
5250 else if (word
> orig_text
)
5252 /* Return some portion of sym_name. */
5253 completion
= xmalloc (strlen (match
) + 5);
5254 strcpy (completion
, match
+ (word
- orig_text
));
5258 /* Return some of ORIG_TEXT plus sym_name. */
5259 completion
= xmalloc (strlen (match
) + (orig_text
- word
) + 5);
5260 strncpy (completion
, word
, orig_text
- word
);
5261 completion
[orig_text
- word
] = '\0';
5262 strcat (completion
, match
);
5265 string_vector_append (sv
, completion
);
5268 /* Return a list of possible symbol names completing TEXT0. The list
5269 is NULL terminated. WORD is the entire command on which completion
5273 ada_make_symbol_completion_list (const char *text0
, const char *word
)
5275 /* Note: This function is almost a copy of make_symbol_completion_list(),
5276 except it has been adapted for Ada. It is somewhat of a shame to
5277 duplicate so much code, but we don't really have the infrastructure
5278 yet to develop a language-aware version of he symbol completer... */
5283 struct string_vector result
= xnew_string_vector (128);
5286 struct partial_symtab
*ps
;
5287 struct minimal_symbol
*msymbol
;
5288 struct objfile
*objfile
;
5289 struct block
*b
, *surrounding_static_block
= 0;
5291 struct dict_iterator iter
;
5293 if (text0
[0] == '<')
5295 text
= xstrdup (text0
);
5296 make_cleanup (xfree
, text
);
5297 text_len
= strlen (text
);
5303 text
= xstrdup (ada_encode (text0
));
5304 make_cleanup (xfree
, text
);
5305 text_len
= strlen (text
);
5306 for (i
= 0; i
< text_len
; i
++)
5307 text
[i
] = tolower (text
[i
]);
5309 /* FIXME: brobecker/2003-09-17: When we get rid of ADA_RETAIN_DOTS,
5310 we can restrict the wild_match check to searching "__" only. */
5311 wild_match
= (strstr (text0
, "__") == NULL
5312 && strchr (text0
, '.') == NULL
);
5313 encoded
= (strstr (text0
, "__") != NULL
);
5316 /* First, look at the partial symtab symbols. */
5317 ALL_PSYMTABS (objfile
, ps
)
5319 struct partial_symbol
**psym
;
5321 /* If the psymtab's been read in we'll get it when we search
5322 through the blockvector. */
5326 for (psym
= objfile
->global_psymbols
.list
+ ps
->globals_offset
;
5327 psym
< (objfile
->global_psymbols
.list
+ ps
->globals_offset
5328 + ps
->n_global_syms
); psym
++)
5331 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (*psym
),
5332 text
, text_len
, text0
, word
,
5333 wild_match
, encoded
);
5336 for (psym
= objfile
->static_psymbols
.list
+ ps
->statics_offset
;
5337 psym
< (objfile
->static_psymbols
.list
+ ps
->statics_offset
5338 + ps
->n_static_syms
); psym
++)
5341 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (*psym
),
5342 text
, text_len
, text0
, word
,
5343 wild_match
, encoded
);
5347 /* At this point scan through the misc symbol vectors and add each
5348 symbol you find to the list. Eventually we want to ignore
5349 anything that isn't a text symbol (everything else will be
5350 handled by the psymtab code above). */
5352 ALL_MSYMBOLS (objfile
, msymbol
)
5355 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (msymbol
),
5356 text
, text_len
, text0
, word
, wild_match
, encoded
);
5359 /* Search upwards from currently selected frame (so that we can
5360 complete on local vars. */
5362 for (b
= get_selected_block (0); b
!= NULL
; b
= BLOCK_SUPERBLOCK (b
))
5364 if (!BLOCK_SUPERBLOCK (b
))
5365 surrounding_static_block
= b
; /* For elmin of dups */
5367 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5369 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5370 text
, text_len
, text0
, word
,
5371 wild_match
, encoded
);
5375 /* Go through the symtabs and check the externs and statics for
5376 symbols which match. */
5378 ALL_SYMTABS (objfile
, s
)
5381 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
5382 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5384 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5385 text
, text_len
, text0
, word
,
5386 wild_match
, encoded
);
5390 ALL_SYMTABS (objfile
, s
)
5393 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
5394 /* Don't do this block twice. */
5395 if (b
== surrounding_static_block
)
5397 ALL_BLOCK_SYMBOLS (b
, iter
, sym
)
5399 symbol_completion_add (&result
, SYMBOL_LINKAGE_NAME (sym
),
5400 text
, text_len
, text0
, word
,
5401 wild_match
, encoded
);
5405 /* Append the closing NULL entry. */
5406 string_vector_append (&result
, NULL
);
5408 return (result
.array
);
5411 #endif /* GNAT_GDB */
5414 /* Breakpoint-related */
5416 /* Assuming that LINE is pointing at the beginning of an argument to
5417 'break', return a pointer to the delimiter for the initial segment
5418 of that name. This is the first ':', ' ', or end of LINE. */
5421 ada_start_decode_line_1 (char *line
)
5423 /* NOTE: strpbrk would be more elegant, but I am reluctant to be
5424 the first to use such a library function in GDB code. */
5426 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
5431 /* *SPEC points to a function and line number spec (as in a break
5432 command), following any initial file name specification.
5434 Return all symbol table/line specfications (sals) consistent with the
5435 information in *SPEC and FILE_TABLE in the following sense:
5436 + FILE_TABLE is null, or the sal refers to a line in the file
5437 named by FILE_TABLE.
5438 + If *SPEC points to an argument with a trailing ':LINENUM',
5439 then the sal refers to that line (or one following it as closely as
5441 + If *SPEC does not start with '*', the sal is in a function with
5444 Returns with 0 elements if no matching non-minimal symbols found.
5446 If *SPEC begins with a function name of the form <NAME>, then NAME
5447 is taken as a literal name; otherwise the function name is subject
5448 to the usual encoding.
5450 *SPEC is updated to point after the function/line number specification.
5452 FUNFIRSTLINE is non-zero if we desire the first line of real code
5455 If CANONICAL is non-NULL, and if any of the sals require a
5456 'canonical line spec', then *CANONICAL is set to point to an array
5457 of strings, corresponding to and equal in length to the returned
5458 list of sals, such that (*CANONICAL)[i] is non-null and contains a
5459 canonical line spec for the ith returned sal, if needed. If no
5460 canonical line specs are required and CANONICAL is non-null,
5461 *CANONICAL is set to NULL.
5463 A 'canonical line spec' is simply a name (in the format of the
5464 breakpoint command) that uniquely identifies a breakpoint position,
5465 with no further contextual information or user selection. It is
5466 needed whenever the file name, function name, and line number
5467 information supplied is insufficient for this unique
5468 identification. Currently overloaded functions, the name '*',
5469 or static functions without a filename yield a canonical line spec.
5470 The array and the line spec strings are allocated on the heap; it
5471 is the caller's responsibility to free them. */
5473 struct symtabs_and_lines
5474 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
5475 int funfirstline
, char ***canonical
)
5477 struct ada_symbol_info
*symbols
;
5478 const struct block
*block
;
5479 int n_matches
, i
, line_num
;
5480 struct symtabs_and_lines selected
;
5481 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
5487 char *unquoted_name
;
5489 if (file_table
== NULL
)
5490 block
= block_static_block (get_selected_block (0));
5492 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
5494 if (canonical
!= NULL
)
5495 *canonical
= (char **) NULL
;
5497 is_quoted
= (**spec
&& strchr (get_gdb_completer_quote_characters (),
5506 *spec
= skip_quoted (*spec
);
5507 while (**spec
!= '\000'
5508 && !strchr (ada_completer_word_break_characters
, **spec
))
5514 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
5516 line_num
= strtol (*spec
+ 1, spec
, 10);
5517 while (**spec
== ' ' || **spec
== '\t')
5524 error ("Wild-card function with no line number or file name.");
5526 return ada_sals_for_line (file_table
->filename
, line_num
,
5527 funfirstline
, canonical
, 0);
5530 if (name
[0] == '\'')
5538 unquoted_name
= (char *) alloca (len
- 1);
5539 memcpy (unquoted_name
, name
+ 1, len
- 2);
5540 unquoted_name
[len
- 2] = '\000';
5545 unquoted_name
= (char *) alloca (len
+ 1);
5546 memcpy (unquoted_name
, name
, len
);
5547 unquoted_name
[len
] = '\000';
5548 lower_name
= (char *) alloca (len
+ 1);
5549 for (i
= 0; i
< len
; i
+= 1)
5550 lower_name
[i
] = tolower (name
[i
]);
5551 lower_name
[len
] = '\000';
5555 if (lower_name
!= NULL
)
5556 n_matches
= ada_lookup_symbol_list (ada_encode (lower_name
), block
,
5557 VAR_DOMAIN
, &symbols
);
5559 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
5560 VAR_DOMAIN
, &symbols
);
5561 if (n_matches
== 0 && line_num
>= 0)
5562 error ("No line number information found for %s.", unquoted_name
);
5563 else if (n_matches
== 0)
5565 #ifdef HPPA_COMPILER_BUG
5566 /* FIXME: See comment in symtab.c::decode_line_1 */
5568 volatile struct symtab_and_line val
;
5569 #define volatile /*nothing */
5571 struct symtab_and_line val
;
5573 struct minimal_symbol
*msymbol
;
5578 if (lower_name
!= NULL
)
5579 msymbol
= ada_lookup_simple_minsym (ada_encode (lower_name
));
5580 if (msymbol
== NULL
)
5581 msymbol
= ada_lookup_simple_minsym (unquoted_name
);
5582 if (msymbol
!= NULL
)
5584 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
5585 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
5588 val
.pc
+= DEPRECATED_FUNCTION_START_OFFSET
;
5589 SKIP_PROLOGUE (val
.pc
);
5591 selected
.sals
= (struct symtab_and_line
*)
5592 xmalloc (sizeof (struct symtab_and_line
));
5593 selected
.sals
[0] = val
;
5598 if (!have_full_symbols ()
5599 && !have_partial_symbols () && !have_minimal_symbols ())
5600 error ("No symbol table is loaded. Use the \"file\" command.");
5602 error ("Function \"%s\" not defined.", unquoted_name
);
5603 return selected
; /* for lint */
5608 struct symtabs_and_lines best_sal
=
5609 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
5610 symbols
, n_matches
);
5612 adjust_pc_past_prologue (&best_sal
.sals
[0].pc
);
5617 selected
.nelts
= user_select_syms (symbols
, n_matches
, n_matches
);
5620 selected
.sals
= (struct symtab_and_line
*)
5621 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
5622 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
5623 make_cleanup (xfree
, selected
.sals
);
5626 while (i
< selected
.nelts
)
5628 if (SYMBOL_CLASS (symbols
[i
].sym
) == LOC_BLOCK
)
5630 = find_function_start_sal (symbols
[i
].sym
, funfirstline
);
5631 else if (SYMBOL_LINE (symbols
[i
].sym
) != 0)
5633 selected
.sals
[i
].symtab
=
5635 ? symbols
[i
].symtab
: symtab_for_sym (symbols
[i
].sym
);
5636 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
].sym
);
5638 else if (line_num
>= 0)
5640 /* Ignore this choice */
5641 symbols
[i
] = symbols
[selected
.nelts
- 1];
5642 selected
.nelts
-= 1;
5646 error ("Line number not known for symbol \"%s\"", unquoted_name
);
5650 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
5652 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
5653 for (i
= 0; i
< selected
.nelts
; i
+= 1)
5655 extended_canonical_line_spec (selected
.sals
[i
],
5656 SYMBOL_PRINT_NAME (symbols
[i
].sym
));
5659 discard_cleanups (old_chain
);
5663 /* The (single) sal corresponding to line LINE_NUM in a symbol table
5664 with file name FILENAME that occurs in one of the functions listed
5665 in the symbol fields of SYMBOLS[0 .. NSYMS-1]. */
5667 static struct symtabs_and_lines
5668 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
5669 struct ada_symbol_info
*symbols
, int nsyms
)
5671 struct symtabs_and_lines sals
;
5672 int best_index
, best
;
5673 struct linetable
*best_linetable
;
5674 struct objfile
*objfile
;
5676 struct symtab
*best_symtab
;
5678 read_all_symtabs (filename
);
5681 best_linetable
= NULL
;
5684 ALL_SYMTABS (objfile
, s
)
5686 struct linetable
*l
;
5691 if (strcmp (filename
, s
->filename
) != 0)
5694 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
5704 if (best
== 0 || l
->item
[ind
].line
< best
)
5706 best
= l
->item
[ind
].line
;
5715 error ("Line number not found in designated function.");
5720 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
5722 init_sal (&sals
.sals
[0]);
5724 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
5725 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
5726 sals
.sals
[0].symtab
= best_symtab
;
5731 /* Return the index in LINETABLE of the best match for LINE_NUM whose
5732 pc falls within one of the functions denoted by the symbol fields
5733 of SYMBOLS[0..NSYMS-1]. Set *EXACTP to 1 if the match is exact,
5737 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
5738 struct ada_symbol_info
*symbols
, int nsyms
,
5741 int i
, len
, best_index
, best
;
5743 if (line_num
<= 0 || linetable
== NULL
)
5746 len
= linetable
->nitems
;
5747 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
5750 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5752 for (k
= 0; k
< nsyms
; k
+= 1)
5754 if (symbols
[k
].sym
!= NULL
5755 && SYMBOL_CLASS (symbols
[k
].sym
) == LOC_BLOCK
5756 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
].sym
))
5757 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
].sym
)))
5764 if (item
->line
== line_num
)
5770 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
5781 /* Find the smallest k >= LINE_NUM such that k is a line number in
5782 LINETABLE, and k falls strictly within a named function that begins at
5783 or before LINE_NUM. Return -1 if there is no such k. */
5786 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
5790 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
5792 len
= linetable
->nitems
;
5798 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5800 if (item
->line
>= line_num
&& item
->line
< best
)
5803 CORE_ADDR start
, end
;
5806 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
5808 if (func_name
!= NULL
&& item
->pc
< end
)
5810 if (item
->line
== line_num
)
5814 struct symbol
*sym
=
5815 standard_lookup (func_name
, NULL
, VAR_DOMAIN
);
5816 if (is_plausible_func_for_line (sym
, line_num
))
5822 while (i
< len
&& linetable
->item
[i
].pc
< end
);
5832 return (best
== INT_MAX
) ? -1 : best
;
5836 /* Return the next higher index, k, into LINETABLE such that k > IND,
5837 entry k in LINETABLE has a line number equal to LINE_NUM, k
5838 corresponds to a PC that is in a function different from that
5839 corresponding to IND, and falls strictly within a named function
5840 that begins at a line at or preceding STARTING_LINE.
5841 Return -1 if there is no such k.
5842 IND == -1 corresponds to no function. */
5845 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
5846 int starting_line
, int ind
)
5850 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
5852 len
= linetable
->nitems
;
5856 CORE_ADDR start
, end
;
5858 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
5859 (char **) NULL
, &start
, &end
))
5861 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
5873 struct linetable_entry
*item
= &(linetable
->item
[i
]);
5875 if (item
->line
>= line_num
)
5878 CORE_ADDR start
, end
;
5881 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
5883 if (func_name
!= NULL
&& item
->pc
< end
)
5885 if (item
->line
== line_num
)
5887 struct symbol
*sym
=
5888 standard_lookup (func_name
, NULL
, VAR_DOMAIN
);
5889 if (is_plausible_func_for_line (sym
, starting_line
))
5893 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
5905 /* True iff function symbol SYM starts somewhere at or before line #
5909 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
5911 struct symtab_and_line start_sal
;
5916 start_sal
= find_function_start_sal (sym
, 0);
5918 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
5921 /* Read in all symbol tables corresponding to partial symbol tables
5922 with file name FILENAME. */
5925 read_all_symtabs (const char *filename
)
5927 struct partial_symtab
*ps
;
5928 struct objfile
*objfile
;
5930 ALL_PSYMTABS (objfile
, ps
)
5934 if (strcmp (filename
, ps
->filename
) == 0)
5935 PSYMTAB_TO_SYMTAB (ps
);
5939 /* All sals corresponding to line LINE_NUM in a symbol table from file
5940 FILENAME, as filtered by the user. Filter out any lines that
5941 reside in functions with "suppressed" names (not corresponding to
5942 explicit Ada functions), if there is at least one in a function
5943 with a non-suppressed name. If CANONICAL is not null, set
5944 it to a corresponding array of canonical line specs.
5945 If ONE_LOCATION_ONLY is set and several matches are found for
5946 the given location, then automatically select the first match found
5947 instead of asking the user which instance should be returned. */
5949 struct symtabs_and_lines
5950 ada_sals_for_line (const char *filename
, int line_num
,
5951 int funfirstline
, char ***canonical
, int one_location_only
)
5953 struct symtabs_and_lines result
;
5954 struct objfile
*objfile
;
5956 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
5959 read_all_symtabs (filename
);
5962 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
5965 make_cleanup (free_current_contents
, &result
.sals
);
5967 ALL_SYMTABS (objfile
, s
)
5969 int ind
, target_line_num
;
5973 if (strcmp (s
->filename
, filename
) != 0)
5977 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
5978 if (target_line_num
== -1)
5985 find_next_line_in_linetable (LINETABLE (s
),
5986 target_line_num
, line_num
, ind
);
5991 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
5992 init_sal (&result
.sals
[result
.nelts
]);
5993 result
.sals
[result
.nelts
].line
= line_num
;
5994 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
5995 result
.sals
[result
.nelts
].symtab
= s
;
5998 adjust_pc_past_prologue (&result
.sals
[result
.nelts
].pc
);
6004 if (canonical
!= NULL
|| result
.nelts
> 1)
6007 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
6008 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
6009 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
6011 for (k
= 0; k
< result
.nelts
; k
+= 1)
6013 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
6014 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
6015 if (func_names
[k
] == NULL
)
6016 error ("Could not find function for one or more breakpoints.");
6019 /* Remove suppressed names, unless all are suppressed. */
6020 for (j
= 0; j
< result
.nelts
; j
+= 1)
6021 if (!is_suppressed_name (func_names
[j
]))
6023 /* At least one name is unsuppressed, so remove all
6024 suppressed names. */
6025 for (k
= n
= 0; k
< result
.nelts
; k
+= 1)
6026 if (!is_suppressed_name (func_names
[k
]))
6028 func_names
[n
] = func_names
[k
];
6029 result
.sals
[n
] = result
.sals
[k
];
6036 if (result
.nelts
> 1)
6038 if (one_location_only
)
6040 /* Automatically select the first of all possible choices. */
6046 printf_unfiltered ("[0] cancel\n");
6047 if (result
.nelts
> 1)
6048 printf_unfiltered ("[1] all\n");
6049 for (k
= 0; k
< result
.nelts
; k
+= 1)
6050 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
6051 ada_decode (func_names
[k
]));
6053 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
6054 result
.nelts
> 1, "instance-choice");
6057 for (k
= 0; k
< n
; k
+= 1)
6059 result
.sals
[k
] = result
.sals
[choices
[k
]];
6060 func_names
[k
] = func_names
[choices
[k
]];
6065 if (canonical
!= NULL
&& result
.nelts
== 0)
6067 else if (canonical
!= NULL
)
6069 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
6070 make_cleanup (xfree
, *canonical
);
6071 for (k
= 0; k
< result
.nelts
; k
+= 1)
6074 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
6075 if ((*canonical
)[k
] == NULL
)
6076 error ("Could not locate one or more breakpoints.");
6077 make_cleanup (xfree
, (*canonical
)[k
]);
6082 if (result
.nelts
== 0)
6084 do_cleanups (old_chain
);
6088 discard_cleanups (old_chain
);
6093 /* A canonical line specification of the form FILE:NAME:LINENUM for
6094 symbol table and line data SAL. NULL if insufficient
6095 information. The caller is responsible for releasing any space
6099 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
6103 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
6106 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
6107 + sizeof (sal
.line
) * 3 + 3);
6108 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
6112 /* Return type of Ada breakpoint associated with bp_stat:
6113 0 if not an Ada-specific breakpoint, 1 for break on specific exception,
6114 2 for break on unhandled exception, 3 for assert. */
6117 ada_exception_breakpoint_type (bpstat bs
)
6119 return ((!bs
|| !bs
->breakpoint_at
) ? 0
6120 : bs
->breakpoint_at
->break_on_exception
);
6123 /* True iff FRAME is very likely to be that of a function that is
6124 part of the runtime system. This is all very heuristic, but is
6125 intended to be used as advice as to what frames are uninteresting
6129 is_known_support_routine (struct frame_info
*frame
)
6131 struct frame_info
*next_frame
= get_next_frame (frame
);
6132 /* If frame is not innermost, that normally means that frame->pc
6133 points to *after* the call instruction, and we want to get the line
6134 containing the call, never the next line. But if the next frame is
6135 a signal_handler_caller or a dummy frame, then the next frame was
6136 not entered as the result of a call, and we want to get the line
6137 containing frame->pc. */
6138 const int pc_is_after_call
=
6140 && get_frame_type (next_frame
) != SIGTRAMP_FRAME
6141 && get_frame_type (next_frame
) != DUMMY_FRAME
;
6142 struct symtab_and_line sal
6143 = find_pc_line (get_frame_pc (frame
), pc_is_after_call
);
6149 1. The symtab is null (indicating no debugging symbols)
6150 2. The symtab's filename does not exist.
6151 3. The object file's name is one of the standard libraries.
6152 4. The symtab's file name has the form of an Ada library source file.
6153 5. The function at frame's PC has a GNAT-compiler-generated name. */
6155 if (sal
.symtab
== NULL
)
6158 /* On some systems (e.g. VxWorks), the kernel contains debugging
6159 symbols; in this case, the filename referenced by these symbols
6162 if (stat (sal
.symtab
->filename
, &st
))
6165 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
6167 re_comp (known_runtime_file_name_patterns
[i
]);
6168 if (re_exec (sal
.symtab
->filename
))
6171 if (sal
.symtab
->objfile
!= NULL
)
6173 for (i
= 0; known_runtime_file_name_patterns
[i
] != NULL
; i
+= 1)
6175 re_comp (known_runtime_file_name_patterns
[i
]);
6176 if (re_exec (sal
.symtab
->objfile
->name
))
6181 /* If the frame PC points after the call instruction, then we need to
6182 decrement it in order to search for the function associated to this
6183 PC. Otherwise, if the associated call was the last instruction of
6184 the function, we might either find the wrong function or even fail
6185 during the function name lookup. */
6186 if (pc_is_after_call
)
6187 func_name
= function_name_from_pc (get_frame_pc (frame
) - 1);
6189 func_name
= function_name_from_pc (get_frame_pc (frame
));
6191 if (func_name
== NULL
)
6194 for (i
= 0; known_auxiliary_function_name_patterns
[i
] != NULL
; i
+= 1)
6196 re_comp (known_auxiliary_function_name_patterns
[i
]);
6197 if (re_exec (func_name
))
6204 /* Find the first frame that contains debugging information and that is not
6205 part of the Ada run-time, starting from FI and moving upward. */
6208 ada_find_printable_frame (struct frame_info
*fi
)
6210 for (; fi
!= NULL
; fi
= get_prev_frame (fi
))
6212 if (!is_known_support_routine (fi
))
6221 /* Name found for exception associated with last bpstat sent to
6222 ada_adjust_exception_stop. Set to the null string if that bpstat
6223 did not correspond to an Ada exception or no name could be found. */
6225 static char last_exception_name
[256];
6227 /* If BS indicates a stop in an Ada exception, try to go up to a frame
6228 that will be meaningful to the user, and save the name of the last
6229 exception (truncated, if necessary) in last_exception_name. */
6232 ada_adjust_exception_stop (bpstat bs
)
6235 struct frame_info
*fi
;
6237 char *selected_frame_func
;
6240 last_exception_name
[0] = '\0';
6241 fi
= get_selected_frame ();
6242 selected_frame_func
= function_name_from_pc (get_frame_pc (fi
));
6244 switch (ada_exception_breakpoint_type (bs
))
6251 /* Unhandled exceptions. Select the frame corresponding to
6252 ada.exceptions.process_raise_exception. This frame is at
6253 least 2 levels up, so we simply skip the first 2 frames
6254 without checking the name of their associated function. */
6255 for (frame_level
= 0; frame_level
< 2; frame_level
+= 1)
6257 fi
= get_prev_frame (fi
);
6260 const char *func_name
= function_name_from_pc (get_frame_pc (fi
));
6261 if (func_name
!= NULL
6262 && strcmp (func_name
, process_raise_exception_name
) == 0)
6263 break; /* We found the frame we were looking for... */
6264 fi
= get_prev_frame (fi
);
6272 addr
= parse_and_eval_address ("e.full_name");
6275 read_memory (addr
, last_exception_name
, sizeof (last_exception_name
) - 1);
6276 last_exception_name
[sizeof (last_exception_name
) - 1] = '\0';
6277 ada_find_printable_frame (get_selected_frame ());
6280 /* Output Ada exception name (if any) associated with last call to
6281 ada_adjust_exception_stop. */
6284 ada_print_exception_stop (bpstat bs
)
6286 if (last_exception_name
[0] != '\000')
6288 ui_out_text (uiout
, last_exception_name
);
6289 ui_out_text (uiout
, " at ");
6293 /* Parses the CONDITION string associated with a breakpoint exception
6294 to get the name of the exception on which the breakpoint has been
6295 set. The returned string needs to be deallocated after use. */
6298 exception_name_from_cond (const char *condition
)
6300 char *start
, *end
, *exception_name
;
6301 int exception_name_len
;
6303 start
= strrchr (condition
, '&') + 1;
6304 end
= strchr (start
, ')') - 1;
6305 exception_name_len
= end
- start
+ 1;
6308 (char *) xmalloc ((exception_name_len
+ 1) * sizeof (char));
6309 sprintf (exception_name
, "%.*s", exception_name_len
, start
);
6311 return exception_name
;
6314 /* Print Ada-specific exception information about B, other than task
6315 clause. Return non-zero iff B was an Ada exception breakpoint. */
6318 ada_print_exception_breakpoint_nontask (struct breakpoint
*b
)
6320 if (b
->break_on_exception
== 1)
6322 if (b
->cond_string
) /* the breakpoint is on a specific exception. */
6324 char *exception_name
= exception_name_from_cond (b
->cond_string
);
6326 make_cleanup (xfree
, exception_name
);
6328 ui_out_text (uiout
, "on ");
6329 if (ui_out_is_mi_like_p (uiout
))
6330 ui_out_field_string (uiout
, "exception", exception_name
);
6333 ui_out_text (uiout
, "exception ");
6334 ui_out_text (uiout
, exception_name
);
6335 ui_out_text (uiout
, " ");
6339 ui_out_text (uiout
, "on all exceptions");
6341 else if (b
->break_on_exception
== 2)
6342 ui_out_text (uiout
, "on unhandled exception");
6343 else if (b
->break_on_exception
== 3)
6344 ui_out_text (uiout
, "on assert failure");
6350 /* Print task identifier for breakpoint B, if it is an Ada-specific
6351 breakpoint with non-zero tasking information. */
6354 ada_print_exception_breakpoint_task (struct breakpoint
*b
)
6358 ui_out_text (uiout
, " task ");
6359 ui_out_field_int (uiout
, "task", b
->task
);
6364 ada_is_exception_sym (struct symbol
*sym
)
6366 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
6368 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
6369 && SYMBOL_CLASS (sym
) != LOC_BLOCK
6370 && SYMBOL_CLASS (sym
) != LOC_CONST
6371 && type_name
!= NULL
&& strcmp (type_name
, "exception") == 0);
6375 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
6377 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
6378 && SYMBOL_CLASS (sym
) != LOC_BLOCK
6379 && SYMBOL_CLASS (sym
) != LOC_CONST
);
6382 /* Cause the appropriate error if no appropriate runtime symbol is
6383 found to set a breakpoint, using ERR_DESC to describe the
6387 error_breakpoint_runtime_sym_not_found (const char *err_desc
)
6389 /* If we are not debugging an Ada program, we can not put exception
6392 if (ada_update_initial_language (language_unknown
, NULL
) != language_ada
)
6393 error ("Unable to break on %s. Is this an Ada main program?", err_desc
);
6395 /* If the symbol does not exist, then check that the program is
6396 already started, to make sure that shared libraries have been
6397 loaded. If it is not started, this may mean that the symbol is
6398 in a shared library. */
6400 if (ptid_get_pid (inferior_ptid
) == 0)
6401 error ("Unable to break on %s. Try to start the program first.",
6404 /* At this point, we know that we are debugging an Ada program and
6405 that the inferior has been started, but we still are not able to
6406 find the run-time symbols. That can mean that we are in
6407 configurable run time mode, or that a-except as been optimized
6408 out by the linker... In any case, at this point it is not worth
6409 supporting this feature. */
6411 error ("Cannot break on %s in this configuration.", err_desc
);
6414 /* Test if NAME is currently defined, and that either ALLOW_TRAMP or
6415 the symbol is not a shared-library trampoline. Return the result of
6419 is_runtime_sym_defined (const char *name
, int allow_tramp
)
6421 struct minimal_symbol
*msym
;
6423 msym
= lookup_minimal_symbol (name
, NULL
, NULL
);
6424 return (msym
!= NULL
&& msym
->type
!= mst_unknown
6425 && (allow_tramp
|| msym
->type
!= mst_solib_trampoline
));
6428 /* If ARG points to an Ada exception or assert breakpoint, rewrite
6429 into equivalent form. Return resulting argument string. Set
6430 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
6431 break on unhandled, 3 for assert, 0 otherwise. */
6434 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
6438 *break_on_exceptionp
= 0;
6439 if (current_language
->la_language
== language_ada
6440 && strncmp (arg
, "exception", 9) == 0
6441 && (arg
[9] == ' ' || arg
[9] == '\t' || arg
[9] == '\0'))
6443 char *tok
, *end_tok
;
6445 int has_exception_propagation
=
6446 is_runtime_sym_defined (raise_sym_name
, 1);
6448 *break_on_exceptionp
= 1;
6451 while (*tok
== ' ' || *tok
== '\t')
6456 while (*end_tok
!= ' ' && *end_tok
!= '\t' && *end_tok
!= '\000')
6459 toklen
= end_tok
- tok
;
6461 arg
= (char *) xmalloc (sizeof (longest_exception_template
) + toklen
);
6462 make_cleanup (xfree
, arg
);
6465 if (has_exception_propagation
)
6466 sprintf (arg
, "'%s'", raise_sym_name
);
6468 error_breakpoint_runtime_sym_not_found ("exception");
6470 else if (strncmp (tok
, "unhandled", toklen
) == 0)
6472 if (is_runtime_sym_defined (raise_unhandled_sym_name
, 1))
6473 sprintf (arg
, "'%s'", raise_unhandled_sym_name
);
6475 error_breakpoint_runtime_sym_not_found ("exception");
6477 *break_on_exceptionp
= 2;
6481 if (is_runtime_sym_defined (raise_sym_name
, 0))
6482 sprintf (arg
, "'%s' if long_integer(e) = long_integer(&%.*s)",
6483 raise_sym_name
, toklen
, tok
);
6485 error_breakpoint_runtime_sym_not_found ("specific exception");
6488 else if (current_language
->la_language
== language_ada
6489 && strncmp (arg
, "assert", 6) == 0
6490 && (arg
[6] == ' ' || arg
[6] == '\t' || arg
[6] == '\0'))
6492 char *tok
= arg
+ 6;
6494 if (!is_runtime_sym_defined (raise_assert_sym_name
, 1))
6495 error_breakpoint_runtime_sym_not_found ("failed assertion");
6497 *break_on_exceptionp
= 3;
6500 (char *) xmalloc (sizeof (raise_assert_sym_name
) + strlen (tok
) + 2);
6501 make_cleanup (xfree
, arg
);
6502 sprintf (arg
, "'%s'%s", raise_assert_sym_name
, tok
);
6510 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
6511 to be invisible to users. */
6514 ada_is_ignored_field (struct type
*type
, int field_num
)
6516 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
6520 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6521 return (name
== NULL
6522 || (name
[0] == '_' && strncmp (name
, "_parent", 7) != 0));
6526 /* True iff TYPE has a tag field. If REFOK, then TYPE may also be a
6527 pointer or reference type whose ultimate target has a tag field. */
6530 ada_is_tagged_type (struct type
*type
, int refok
)
6532 return (ada_lookup_struct_elt_type (type
, "_tag", refok
, 1, NULL
) != NULL
);
6535 /* True iff TYPE represents the type of X'Tag */
6538 ada_is_tag_type (struct type
*type
)
6540 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_PTR
)
6544 const char *name
= ada_type_name (TYPE_TARGET_TYPE (type
));
6545 return (name
!= NULL
6546 && strcmp (name
, "ada__tags__dispatch_table") == 0);
6550 /* The type of the tag on VAL. */
6553 ada_tag_type (struct value
*val
)
6555 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 1, 0, NULL
);
6558 /* The value of the tag on VAL. */
6561 ada_value_tag (struct value
*val
)
6563 return ada_value_struct_elt (val
, "_tag", "record");
6566 /* The value of the tag on the object of type TYPE whose contents are
6567 saved at VALADDR, if it is non-null, or is at memory address
6570 static struct value
*
6571 value_tag_from_contents_and_address (struct type
*type
, char *valaddr
,
6574 int tag_byte_offset
, dummy1
, dummy2
;
6575 struct type
*tag_type
;
6576 if (find_struct_field ("_tag", type
, 0, &tag_type
, &tag_byte_offset
,
6579 char *valaddr1
= (valaddr
== NULL
) ? NULL
: valaddr
+ tag_byte_offset
;
6580 CORE_ADDR address1
= (address
== 0) ? 0 : address
+ tag_byte_offset
;
6582 return value_from_contents_and_address (tag_type
, valaddr1
, address1
);
6587 static struct type
*
6588 type_from_tag (struct value
*tag
)
6590 const char *type_name
= ada_tag_name (tag
);
6591 if (type_name
!= NULL
)
6592 return ada_find_any_type (ada_encode (type_name
));
6602 /* Wrapper function used by ada_tag_name. Given a struct tag_args*
6603 value ARGS, sets ARGS->name to the tag name of ARGS->tag.
6604 The value stored in ARGS->name is valid until the next call to
6608 ada_tag_name_1 (void *args0
)
6610 struct tag_args
*args
= (struct tag_args
*) args0
;
6611 static char name
[1024];
6615 val
= ada_value_struct_elt (args
->tag
, "tsd", NULL
);
6618 val
= ada_value_struct_elt (val
, "expanded_name", NULL
);
6621 read_memory_string (value_as_address (val
), name
, sizeof (name
) - 1);
6622 for (p
= name
; *p
!= '\0'; p
+= 1)
6629 /* The type name of the dynamic type denoted by the 'tag value TAG, as
6633 ada_tag_name (struct value
*tag
)
6635 struct tag_args args
;
6636 if (!ada_is_tag_type (VALUE_TYPE (tag
)))
6640 catch_errors (ada_tag_name_1
, &args
, NULL
, RETURN_MASK_ALL
);
6644 /* The parent type of TYPE, or NULL if none. */
6647 ada_parent_type (struct type
*type
)
6651 CHECK_TYPEDEF (type
);
6653 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
6656 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6657 if (ada_is_parent_field (type
, i
))
6658 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
6663 /* True iff field number FIELD_NUM of structure type TYPE contains the
6664 parent-type (inherited) fields of a derived type. Assumes TYPE is
6665 a structure type with at least FIELD_NUM+1 fields. */
6668 ada_is_parent_field (struct type
*type
, int field_num
)
6670 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
6671 return (name
!= NULL
6672 && (strncmp (name
, "PARENT", 6) == 0
6673 || strncmp (name
, "_parent", 7) == 0));
6676 /* True iff field number FIELD_NUM of structure type TYPE is a
6677 transparent wrapper field (which should be silently traversed when doing
6678 field selection and flattened when printing). Assumes TYPE is a
6679 structure type with at least FIELD_NUM+1 fields. Such fields are always
6683 ada_is_wrapper_field (struct type
*type
, int field_num
)
6685 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6686 return (name
!= NULL
6687 && (strncmp (name
, "PARENT", 6) == 0
6688 || strcmp (name
, "REP") == 0
6689 || strncmp (name
, "_parent", 7) == 0
6690 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
6693 /* True iff field number FIELD_NUM of structure or union type TYPE
6694 is a variant wrapper. Assumes TYPE is a structure type with at least
6695 FIELD_NUM+1 fields. */
6698 ada_is_variant_part (struct type
*type
, int field_num
)
6700 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
6701 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
6702 || (is_dynamic_field (type
, field_num
)
6703 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
6707 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
6708 whose discriminants are contained in the record type OUTER_TYPE,
6709 returns the type of the controlling discriminant for the variant. */
6712 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
6714 char *name
= ada_variant_discrim_name (var_type
);
6716 ada_lookup_struct_elt_type (outer_type
, name
, 1, 1, NULL
);
6718 return builtin_type_int
;
6723 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
6724 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
6725 represents a 'when others' clause; otherwise 0. */
6728 ada_is_others_clause (struct type
*type
, int field_num
)
6730 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6731 return (name
!= NULL
&& name
[0] == 'O');
6734 /* Assuming that TYPE0 is the type of the variant part of a record,
6735 returns the name of the discriminant controlling the variant.
6736 The value is valid until the next call to ada_variant_discrim_name. */
6739 ada_variant_discrim_name (struct type
*type0
)
6741 static char *result
= NULL
;
6742 static size_t result_len
= 0;
6745 const char *discrim_end
;
6746 const char *discrim_start
;
6748 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
6749 type
= TYPE_TARGET_TYPE (type0
);
6753 name
= ada_type_name (type
);
6755 if (name
== NULL
|| name
[0] == '\000')
6758 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
6761 if (strncmp (discrim_end
, "___XVN", 6) == 0)
6764 if (discrim_end
== name
)
6767 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
6770 if (discrim_start
== name
+ 1)
6772 if ((discrim_start
> name
+ 3
6773 && strncmp (discrim_start
- 3, "___", 3) == 0)
6774 || discrim_start
[-1] == '.')
6778 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
6779 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
6780 result
[discrim_end
- discrim_start
] = '\0';
6784 /* Scan STR for a subtype-encoded number, beginning at position K.
6785 Put the position of the character just past the number scanned in
6786 *NEW_K, if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL.
6787 Return 1 if there was a valid number at the given position, and 0
6788 otherwise. A "subtype-encoded" number consists of the absolute value
6789 in decimal, followed by the letter 'm' to indicate a negative number.
6790 Assumes 0m does not occur. */
6793 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
6797 if (!isdigit (str
[k
]))
6800 /* Do it the hard way so as not to make any assumption about
6801 the relationship of unsigned long (%lu scan format code) and
6804 while (isdigit (str
[k
]))
6806 RU
= RU
* 10 + (str
[k
] - '0');
6813 *R
= (-(LONGEST
) (RU
- 1)) - 1;
6819 /* NOTE on the above: Technically, C does not say what the results of
6820 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
6821 number representable as a LONGEST (although either would probably work
6822 in most implementations). When RU>0, the locution in the then branch
6823 above is always equivalent to the negative of RU. */
6830 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
6831 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
6832 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
6835 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
6837 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
6850 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
6859 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
6860 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
6862 if (val
>= L
&& val
<= U
)
6874 /* FIXME: Lots of redundancy below. Try to consolidate. */
6876 /* Given a value ARG1 (offset by OFFSET bytes) of a struct or union type
6877 ARG_TYPE, extract and return the value of one of its (non-static)
6878 fields. FIELDNO says which field. Differs from value_primitive_field
6879 only in that it can handle packed values of arbitrary type. */
6881 static struct value
*
6882 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
6883 struct type
*arg_type
)
6887 CHECK_TYPEDEF (arg_type
);
6888 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
6890 /* Handle packed fields. */
6892 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
6894 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
6895 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
6897 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
6898 offset
+ bit_pos
/ 8,
6899 bit_pos
% 8, bit_size
, type
);
6902 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
6905 /* Find field with name NAME in object of type TYPE. If found, return 1
6906 after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to
6907 OFFSET + the byte offset of the field within an object of that type,
6908 *BIT_OFFSET_P to the bit offset modulo byte size of the field, and
6909 *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise.
6910 Looks inside wrappers for the field. Returns 0 if field not
6913 find_struct_field (char *name
, struct type
*type
, int offset
,
6914 struct type
**field_type_p
,
6915 int *byte_offset_p
, int *bit_offset_p
, int *bit_size_p
)
6919 CHECK_TYPEDEF (type
);
6920 *field_type_p
= NULL
;
6921 *byte_offset_p
= *bit_offset_p
= *bit_size_p
= 0;
6923 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
6925 int bit_pos
= TYPE_FIELD_BITPOS (type
, i
);
6926 int fld_offset
= offset
+ bit_pos
/ 8;
6927 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6929 if (t_field_name
== NULL
)
6932 else if (field_name_match (t_field_name
, name
))
6934 int bit_size
= TYPE_FIELD_BITSIZE (type
, i
);
6935 *field_type_p
= TYPE_FIELD_TYPE (type
, i
);
6936 *byte_offset_p
= fld_offset
;
6937 *bit_offset_p
= bit_pos
% 8;
6938 *bit_size_p
= bit_size
;
6941 else if (ada_is_wrapper_field (type
, i
))
6943 if (find_struct_field (name
, TYPE_FIELD_TYPE (type
, i
), fld_offset
,
6944 field_type_p
, byte_offset_p
, bit_offset_p
,
6948 else if (ada_is_variant_part (type
, i
))
6951 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
6953 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
6955 if (find_struct_field (name
, TYPE_FIELD_TYPE (field_type
, j
),
6957 + TYPE_FIELD_BITPOS (field_type
, j
) / 8,
6958 field_type_p
, byte_offset_p
,
6959 bit_offset_p
, bit_size_p
))
6969 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
6970 and search in it assuming it has (class) type TYPE.
6971 If found, return value, else return NULL.
6973 Searches recursively through wrapper fields (e.g., '_parent'). */
6975 static struct value
*
6976 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
6980 CHECK_TYPEDEF (type
);
6982 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
6984 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
6986 if (t_field_name
== NULL
)
6989 else if (field_name_match (t_field_name
, name
))
6990 return ada_value_primitive_field (arg
, offset
, i
, type
);
6992 else if (ada_is_wrapper_field (type
, i
))
6994 struct value
*v
= /* Do not let indent join lines here. */
6995 ada_search_struct_field (name
, arg
,
6996 offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8,
6997 TYPE_FIELD_TYPE (type
, i
));
7002 else if (ada_is_variant_part (type
, i
))
7005 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7006 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7008 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7010 struct value
*v
= ada_search_struct_field
/* Force line break. */
7012 var_offset
+ TYPE_FIELD_BITPOS (field_type
, j
) / 8,
7013 TYPE_FIELD_TYPE (field_type
, j
));
7022 /* Given ARG, a value of type (pointer or reference to a)*
7023 structure/union, extract the component named NAME from the ultimate
7024 target structure/union and return it as a value with its
7025 appropriate type. If ARG is a pointer or reference and the field
7026 is not packed, returns a reference to the field, otherwise the
7027 value of the field (an lvalue if ARG is an lvalue).
7029 The routine searches for NAME among all members of the structure itself
7030 and (recursively) among all members of any wrapper members
7033 ERR is a name (for use in error messages) that identifies the class
7034 of entity that ARG is supposed to be. ERR may be null, indicating
7035 that on error, the function simply returns NULL, and does not
7036 throw an error. (FIXME: True only if ARG is a pointer or reference
7040 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
7042 struct type
*t
, *t1
;
7046 t1
= t
= check_typedef (VALUE_TYPE (arg
));
7047 if (TYPE_CODE (t
) == TYPE_CODE_REF
)
7049 t1
= TYPE_TARGET_TYPE (t
);
7055 error ("Bad value type in a %s.", err
);
7058 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7065 while (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7067 t1
= TYPE_TARGET_TYPE (t
);
7073 error ("Bad value type in a %s.", err
);
7076 if (TYPE_CODE (t1
) == TYPE_CODE_PTR
)
7078 arg
= value_ind (arg
);
7085 if (TYPE_CODE (t1
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t1
) != TYPE_CODE_UNION
)
7090 error ("Attempt to extract a component of a value that is not a %s.",
7095 v
= ada_search_struct_field (name
, arg
, 0, t
);
7098 int bit_offset
, bit_size
, byte_offset
;
7099 struct type
*field_type
;
7102 if (TYPE_CODE (t
) == TYPE_CODE_PTR
)
7103 address
= value_as_address (arg
);
7105 address
= unpack_pointer (t
, VALUE_CONTENTS (arg
));
7107 t1
= ada_to_fixed_type (ada_get_base_type (t1
), NULL
, address
, NULL
);
7108 if (find_struct_field (name
, t1
, 0,
7109 &field_type
, &byte_offset
, &bit_offset
,
7114 arg
= ada_value_ind (arg
);
7115 v
= ada_value_primitive_packed_val (arg
, NULL
, byte_offset
,
7116 bit_offset
, bit_size
,
7120 v
= value_from_pointer (lookup_reference_type (field_type
),
7121 address
+ byte_offset
);
7125 if (v
== NULL
&& err
!= NULL
)
7126 error ("There is no member named %s.", name
);
7131 /* Given a type TYPE, look up the type of the component of type named NAME.
7132 If DISPP is non-null, add its byte displacement from the beginning of a
7133 structure (pointed to by a value) of type TYPE to *DISPP (does not
7134 work for packed fields).
7136 Matches any field whose name has NAME as a prefix, possibly
7139 TYPE can be either a struct or union. If REFOK, TYPE may also
7140 be a (pointer or reference)+ to a struct or union, and the
7141 ultimate target type will be searched.
7143 Looks recursively into variant clauses and parent types.
7145 If NOERR is nonzero, return NULL if NAME is not suitably defined or
7146 TYPE is not a type of the right kind. */
7148 static struct type
*
7149 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int refok
,
7150 int noerr
, int *dispp
)
7157 if (refok
&& type
!= NULL
)
7160 CHECK_TYPEDEF (type
);
7161 if (TYPE_CODE (type
) != TYPE_CODE_PTR
7162 && TYPE_CODE (type
) != TYPE_CODE_REF
)
7164 type
= TYPE_TARGET_TYPE (type
);
7168 || (TYPE_CODE (type
) != TYPE_CODE_STRUCT
7169 && TYPE_CODE (type
) != TYPE_CODE_UNION
))
7175 target_terminal_ours ();
7176 gdb_flush (gdb_stdout
);
7177 fprintf_unfiltered (gdb_stderr
, "Type ");
7179 fprintf_unfiltered (gdb_stderr
, "(null)");
7181 type_print (type
, "", gdb_stderr
, -1);
7182 error (" is not a structure or union type");
7186 type
= to_static_fixed_type (type
);
7188 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
7190 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
7194 if (t_field_name
== NULL
)
7197 else if (field_name_match (t_field_name
, name
))
7200 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
7201 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
7204 else if (ada_is_wrapper_field (type
, i
))
7207 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
7212 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7217 else if (ada_is_variant_part (type
, i
))
7220 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
7222 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
7225 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
7230 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
7241 target_terminal_ours ();
7242 gdb_flush (gdb_stdout
);
7243 fprintf_unfiltered (gdb_stderr
, "Type ");
7244 type_print (type
, "", gdb_stderr
, -1);
7245 fprintf_unfiltered (gdb_stderr
, " has no component named ");
7246 error ("%s", name
== NULL
? "<null>" : name
);
7252 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
7253 within a value of type OUTER_TYPE that is stored in GDB at
7254 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
7255 numbering from 0) is applicable. Returns -1 if none are. */
7258 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
7259 char *outer_valaddr
)
7264 struct type
*discrim_type
;
7265 char *discrim_name
= ada_variant_discrim_name (var_type
);
7266 LONGEST discrim_val
;
7270 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, 1, &disp
);
7271 if (discrim_type
== NULL
)
7273 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
7276 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
7278 if (ada_is_others_clause (var_type
, i
))
7280 else if (ada_in_variant (discrim_val
, var_type
, i
))
7284 return others_clause
;
7289 /* Dynamic-Sized Records */
7291 /* Strategy: The type ostensibly attached to a value with dynamic size
7292 (i.e., a size that is not statically recorded in the debugging
7293 data) does not accurately reflect the size or layout of the value.
7294 Our strategy is to convert these values to values with accurate,
7295 conventional types that are constructed on the fly. */
7297 /* There is a subtle and tricky problem here. In general, we cannot
7298 determine the size of dynamic records without its data. However,
7299 the 'struct value' data structure, which GDB uses to represent
7300 quantities in the inferior process (the target), requires the size
7301 of the type at the time of its allocation in order to reserve space
7302 for GDB's internal copy of the data. That's why the
7303 'to_fixed_xxx_type' routines take (target) addresses as parameters,
7304 rather than struct value*s.
7306 However, GDB's internal history variables ($1, $2, etc.) are
7307 struct value*s containing internal copies of the data that are not, in
7308 general, the same as the data at their corresponding addresses in
7309 the target. Fortunately, the types we give to these values are all
7310 conventional, fixed-size types (as per the strategy described
7311 above), so that we don't usually have to perform the
7312 'to_fixed_xxx_type' conversions to look at their values.
7313 Unfortunately, there is one exception: if one of the internal
7314 history variables is an array whose elements are unconstrained
7315 records, then we will need to create distinct fixed types for each
7316 element selected. */
7318 /* The upshot of all of this is that many routines take a (type, host
7319 address, target address) triple as arguments to represent a value.
7320 The host address, if non-null, is supposed to contain an internal
7321 copy of the relevant data; otherwise, the program is to consult the
7322 target at the target address. */
7324 /* Assuming that VAL0 represents a pointer value, the result of
7325 dereferencing it. Differs from value_ind in its treatment of
7326 dynamic-sized types. */
7329 ada_value_ind (struct value
*val0
)
7331 struct value
*val
= unwrap_value (value_ind (val0
));
7332 return ada_to_fixed_value (val
);
7335 /* The value resulting from dereferencing any "reference to"
7336 qualifiers on VAL0. */
7338 static struct value
*
7339 ada_coerce_ref (struct value
*val0
)
7341 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
7343 struct value
*val
= val0
;
7345 val
= unwrap_value (val
);
7346 return ada_to_fixed_value (val
);
7352 /* Return OFF rounded upward if necessary to a multiple of
7353 ALIGNMENT (a power of 2). */
7356 align_value (unsigned int off
, unsigned int alignment
)
7358 return (off
+ alignment
- 1) & ~(alignment
- 1);
7361 /* Return the bit alignment required for field #F of template type TYPE. */
7364 field_alignment (struct type
*type
, int f
)
7366 const char *name
= TYPE_FIELD_NAME (type
, f
);
7367 int len
= (name
== NULL
) ? 0 : strlen (name
);
7370 if (!isdigit (name
[len
- 1]))
7373 if (isdigit (name
[len
- 2]))
7374 align_offset
= len
- 2;
7376 align_offset
= len
- 1;
7378 if (align_offset
< 7 || strncmp ("___XV", name
+ align_offset
- 6, 5) != 0)
7379 return TARGET_CHAR_BIT
;
7381 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
7384 /* Find a symbol named NAME. Ignores ambiguity. */
7387 ada_find_any_symbol (const char *name
)
7391 sym
= standard_lookup (name
, get_selected_block (NULL
), VAR_DOMAIN
);
7392 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
7395 sym
= standard_lookup (name
, NULL
, STRUCT_DOMAIN
);
7399 /* Find a type named NAME. Ignores ambiguity. */
7402 ada_find_any_type (const char *name
)
7404 struct symbol
*sym
= ada_find_any_symbol (name
);
7407 return SYMBOL_TYPE (sym
);
7412 /* Given a symbol NAME and its associated BLOCK, search all symbols
7413 for its ___XR counterpart, which is the ``renaming'' symbol
7414 associated to NAME. Return this symbol if found, return
7418 ada_find_renaming_symbol (const char *name
, struct block
*block
)
7420 const struct symbol
*function_sym
= block_function (block
);
7423 if (function_sym
!= NULL
)
7425 /* If the symbol is defined inside a function, NAME is not fully
7426 qualified. This means we need to prepend the function name
7427 as well as adding the ``___XR'' suffix to build the name of
7428 the associated renaming symbol. */
7429 char *function_name
= SYMBOL_LINKAGE_NAME (function_sym
);
7430 const int function_name_len
= strlen (function_name
);
7431 const int rename_len
= function_name_len
+ 2 /* "__" */
7432 + strlen (name
) + 6 /* "___XR\0" */ ;
7434 /* Library-level functions are a special case, as GNAT adds
7435 a ``_ada_'' prefix to the function name to avoid namespace
7436 pollution. However, the renaming symbol themselves do not
7437 have this prefix, so we need to skip this prefix if present. */
7438 if (function_name_len
> 5 /* "_ada_" */
7439 && strstr (function_name
, "_ada_") == function_name
)
7440 function_name
= function_name
+ 5;
7442 rename
= (char *) alloca (rename_len
* sizeof (char));
7443 sprintf (rename
, "%s__%s___XR", function_name
, name
);
7447 const int rename_len
= strlen (name
) + 6;
7448 rename
= (char *) alloca (rename_len
* sizeof (char));
7449 sprintf (rename
, "%s___XR", name
);
7452 return ada_find_any_symbol (rename
);
7455 /* Because of GNAT encoding conventions, several GDB symbols may match a
7456 given type name. If the type denoted by TYPE0 is to be preferred to
7457 that of TYPE1 for purposes of type printing, return non-zero;
7458 otherwise return 0. */
7461 ada_prefer_type (struct type
*type0
, struct type
*type1
)
7465 else if (type0
== NULL
)
7467 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
7469 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
7471 else if (TYPE_NAME (type1
) == NULL
&& TYPE_NAME (type0
) != NULL
)
7473 else if (ada_is_packed_array_type (type0
))
7475 else if (ada_is_array_descriptor_type (type0
)
7476 && !ada_is_array_descriptor_type (type1
))
7478 else if (ada_renaming_type (type0
) != NULL
7479 && ada_renaming_type (type1
) == NULL
)
7484 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
7485 null, its TYPE_TAG_NAME. Null if TYPE is null. */
7488 ada_type_name (struct type
*type
)
7492 else if (TYPE_NAME (type
) != NULL
)
7493 return TYPE_NAME (type
);
7495 return TYPE_TAG_NAME (type
);
7498 /* Find a parallel type to TYPE whose name is formed by appending
7499 SUFFIX to the name of TYPE. */
7502 ada_find_parallel_type (struct type
*type
, const char *suffix
)
7505 static size_t name_len
= 0;
7507 char *typename
= ada_type_name (type
);
7509 if (typename
== NULL
)
7512 len
= strlen (typename
);
7514 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
7516 strcpy (name
, typename
);
7517 strcpy (name
+ len
, suffix
);
7519 return ada_find_any_type (name
);
7523 /* If TYPE is a variable-size record type, return the corresponding template
7524 type describing its fields. Otherwise, return NULL. */
7526 static struct type
*
7527 dynamic_template_type (struct type
*type
)
7529 CHECK_TYPEDEF (type
);
7531 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
7532 || ada_type_name (type
) == NULL
)
7536 int len
= strlen (ada_type_name (type
));
7537 if (len
> 6 && strcmp (ada_type_name (type
) + len
- 6, "___XVE") == 0)
7540 return ada_find_parallel_type (type
, "___XVE");
7544 /* Assuming that TEMPL_TYPE is a union or struct type, returns
7545 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
7548 is_dynamic_field (struct type
*templ_type
, int field_num
)
7550 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
7552 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
7553 && strstr (name
, "___XVL") != NULL
;
7556 /* The index of the variant field of TYPE, or -1 if TYPE does not
7557 represent a variant record type. */
7560 variant_field_index (struct type
*type
)
7564 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
7567 for (f
= 0; f
< TYPE_NFIELDS (type
); f
+= 1)
7569 if (ada_is_variant_part (type
, f
))
7575 /* A record type with no fields. */
7577 static struct type
*
7578 empty_record (struct objfile
*objfile
)
7580 struct type
*type
= alloc_type (objfile
);
7581 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
7582 TYPE_NFIELDS (type
) = 0;
7583 TYPE_FIELDS (type
) = NULL
;
7584 TYPE_NAME (type
) = "<empty>";
7585 TYPE_TAG_NAME (type
) = NULL
;
7586 TYPE_FLAGS (type
) = 0;
7587 TYPE_LENGTH (type
) = 0;
7591 /* An ordinary record type (with fixed-length fields) that describes
7592 the value of type TYPE at VALADDR or ADDRESS (see comments at
7593 the beginning of this section) VAL according to GNAT conventions.
7594 DVAL0 should describe the (portion of a) record that contains any
7595 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
7596 an outer-level type (i.e., as opposed to a branch of a variant.) A
7597 variant field (unless unchecked) is replaced by a particular branch
7600 If not KEEP_DYNAMIC_FIELDS, then all fields whose position or
7601 length are not statically known are discarded. As a consequence,
7602 VALADDR, ADDRESS and DVAL0 are ignored.
7604 NOTE: Limitations: For now, we assume that dynamic fields and
7605 variants occupy whole numbers of bytes. However, they need not be
7609 ada_template_to_fixed_record_type_1 (struct type
*type
, char *valaddr
,
7610 CORE_ADDR address
, struct value
*dval0
,
7611 int keep_dynamic_fields
)
7613 struct value
*mark
= value_mark ();
7616 int nfields
, bit_len
;
7619 int fld_bit_len
, bit_incr
;
7622 /* Compute the number of fields in this record type that are going
7623 to be processed: unless keep_dynamic_fields, this includes only
7624 fields whose position and length are static will be processed. */
7625 if (keep_dynamic_fields
)
7626 nfields
= TYPE_NFIELDS (type
);
7630 while (nfields
< TYPE_NFIELDS (type
)
7631 && !ada_is_variant_part (type
, nfields
)
7632 && !is_dynamic_field (type
, nfields
))
7636 rtype
= alloc_type (TYPE_OBJFILE (type
));
7637 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7638 INIT_CPLUS_SPECIFIC (rtype
);
7639 TYPE_NFIELDS (rtype
) = nfields
;
7640 TYPE_FIELDS (rtype
) = (struct field
*)
7641 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7642 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
7643 TYPE_NAME (rtype
) = ada_type_name (type
);
7644 TYPE_TAG_NAME (rtype
) = NULL
;
7645 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
7651 for (f
= 0; f
< nfields
; f
+= 1)
7655 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
7656 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
7657 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
7659 if (ada_is_variant_part (type
, f
))
7662 fld_bit_len
= bit_incr
= 0;
7664 else if (is_dynamic_field (type
, f
))
7667 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7671 TYPE_FIELD_TYPE (rtype
, f
) =
7674 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
7675 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7676 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7677 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7678 bit_incr
= fld_bit_len
=
7679 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
7683 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
7684 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
7685 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
7686 bit_incr
= fld_bit_len
=
7687 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
7689 bit_incr
= fld_bit_len
=
7690 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
7692 if (off
+ fld_bit_len
> bit_len
)
7693 bit_len
= off
+ fld_bit_len
;
7695 TYPE_LENGTH (rtype
) =
7696 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7699 /* We handle the variant part, if any, at the end because of certain
7700 odd cases in which it is re-ordered so as NOT the last field of
7701 the record. This can happen in the presence of representation
7703 if (variant_field
>= 0)
7705 struct type
*branch_type
;
7707 off
= TYPE_FIELD_BITPOS (rtype
, variant_field
);
7710 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
7715 to_fixed_variant_branch_type
7716 (TYPE_FIELD_TYPE (type
, variant_field
),
7717 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
7718 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
7719 if (branch_type
== NULL
)
7721 for (f
= variant_field
+ 1; f
< TYPE_NFIELDS (rtype
); f
+= 1)
7722 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7723 TYPE_NFIELDS (rtype
) -= 1;
7727 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7728 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7730 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, variant_field
)) *
7732 if (off
+ fld_bit_len
> bit_len
)
7733 bit_len
= off
+ fld_bit_len
;
7734 TYPE_LENGTH (rtype
) =
7735 align_value (bit_len
, TARGET_CHAR_BIT
) / TARGET_CHAR_BIT
;
7739 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
7741 value_free_to_mark (mark
);
7742 if (TYPE_LENGTH (rtype
) > varsize_limit
)
7743 error ("record type with dynamic size is larger than varsize-limit");
7747 /* As for ada_template_to_fixed_record_type_1 with KEEP_DYNAMIC_FIELDS
7750 static struct type
*
7751 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
7752 CORE_ADDR address
, struct value
*dval0
)
7754 return ada_template_to_fixed_record_type_1 (type
, valaddr
,
7758 /* An ordinary record type in which ___XVL-convention fields and
7759 ___XVU- and ___XVN-convention field types in TYPE0 are replaced with
7760 static approximations, containing all possible fields. Uses
7761 no runtime values. Useless for use in values, but that's OK,
7762 since the results are used only for type determinations. Works on both
7763 structs and unions. Representation note: to save space, we memorize
7764 the result of this function in the TYPE_TARGET_TYPE of the
7767 static struct type
*
7768 template_to_static_fixed_type (struct type
*type0
)
7774 if (TYPE_TARGET_TYPE (type0
) != NULL
)
7775 return TYPE_TARGET_TYPE (type0
);
7777 nfields
= TYPE_NFIELDS (type0
);
7780 for (f
= 0; f
< nfields
; f
+= 1)
7782 struct type
*field_type
= CHECK_TYPEDEF (TYPE_FIELD_TYPE (type0
, f
));
7783 struct type
*new_type
;
7785 if (is_dynamic_field (type0
, f
))
7786 new_type
= to_static_fixed_type (TYPE_TARGET_TYPE (field_type
));
7788 new_type
= to_static_fixed_type (field_type
);
7789 if (type
== type0
&& new_type
!= field_type
)
7791 TYPE_TARGET_TYPE (type0
) = type
= alloc_type (TYPE_OBJFILE (type0
));
7792 TYPE_CODE (type
) = TYPE_CODE (type0
);
7793 INIT_CPLUS_SPECIFIC (type
);
7794 TYPE_NFIELDS (type
) = nfields
;
7795 TYPE_FIELDS (type
) = (struct field
*)
7796 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
7797 memcpy (TYPE_FIELDS (type
), TYPE_FIELDS (type0
),
7798 sizeof (struct field
) * nfields
);
7799 TYPE_NAME (type
) = ada_type_name (type0
);
7800 TYPE_TAG_NAME (type
) = NULL
;
7801 TYPE_FLAGS (type
) |= TYPE_FLAG_FIXED_INSTANCE
;
7802 TYPE_LENGTH (type
) = 0;
7804 TYPE_FIELD_TYPE (type
, f
) = new_type
;
7805 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (type0
, f
);
7810 /* Given an object of type TYPE whose contents are at VALADDR and
7811 whose address in memory is ADDRESS, returns a revision of TYPE --
7812 a non-dynamic-sized record with a variant part -- in which
7813 the variant part is replaced with the appropriate branch. Looks
7814 for discriminant values in DVAL0, which can be NULL if the record
7815 contains the necessary discriminant values. */
7817 static struct type
*
7818 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
7819 CORE_ADDR address
, struct value
*dval0
)
7821 struct value
*mark
= value_mark ();
7824 struct type
*branch_type
;
7825 int nfields
= TYPE_NFIELDS (type
);
7826 int variant_field
= variant_field_index (type
);
7828 if (variant_field
== -1)
7832 dval
= value_from_contents_and_address (type
, valaddr
, address
);
7836 rtype
= alloc_type (TYPE_OBJFILE (type
));
7837 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
7838 INIT_CPLUS_SPECIFIC (rtype
);
7839 TYPE_NFIELDS (rtype
) = nfields
;
7840 TYPE_FIELDS (rtype
) =
7841 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
7842 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
7843 sizeof (struct field
) * nfields
);
7844 TYPE_NAME (rtype
) = ada_type_name (type
);
7845 TYPE_TAG_NAME (rtype
) = NULL
;
7846 TYPE_FLAGS (rtype
) |= TYPE_FLAG_FIXED_INSTANCE
;
7847 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
7849 branch_type
= to_fixed_variant_branch_type
7850 (TYPE_FIELD_TYPE (type
, variant_field
),
7851 cond_offset_host (valaddr
,
7852 TYPE_FIELD_BITPOS (type
, variant_field
)
7854 cond_offset_target (address
,
7855 TYPE_FIELD_BITPOS (type
, variant_field
)
7856 / TARGET_CHAR_BIT
), dval
);
7857 if (branch_type
== NULL
)
7860 for (f
= variant_field
+ 1; f
< nfields
; f
+= 1)
7861 TYPE_FIELDS (rtype
)[f
- 1] = TYPE_FIELDS (rtype
)[f
];
7862 TYPE_NFIELDS (rtype
) -= 1;
7866 TYPE_FIELD_TYPE (rtype
, variant_field
) = branch_type
;
7867 TYPE_FIELD_NAME (rtype
, variant_field
) = "S";
7868 TYPE_FIELD_BITSIZE (rtype
, variant_field
) = 0;
7869 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
7871 TYPE_LENGTH (rtype
) -= TYPE_LENGTH (TYPE_FIELD_TYPE (type
, variant_field
));
7873 value_free_to_mark (mark
);
7877 /* An ordinary record type (with fixed-length fields) that describes
7878 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
7879 beginning of this section]. Any necessary discriminants' values
7880 should be in DVAL, a record value; it may be NULL if the object
7881 at ADDR itself contains any necessary discriminant values.
7882 Additionally, VALADDR and ADDRESS may also be NULL if no discriminant
7883 values from the record are needed. Except in the case that DVAL,
7884 VALADDR, and ADDRESS are all 0 or NULL, a variant field (unless
7885 unchecked) is replaced by a particular branch of the variant.
7887 NOTE: the case in which DVAL and VALADDR are NULL and ADDRESS is 0
7888 is questionable and may be removed. It can arise during the
7889 processing of an unconstrained-array-of-record type where all the
7890 variant branches have exactly the same size. This is because in
7891 such cases, the compiler does not bother to use the XVS convention
7892 when encoding the record. I am currently dubious of this
7893 shortcut and suspect the compiler should be altered. FIXME. */
7895 static struct type
*
7896 to_fixed_record_type (struct type
*type0
, char *valaddr
,
7897 CORE_ADDR address
, struct value
*dval
)
7899 struct type
*templ_type
;
7901 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
7904 templ_type
= dynamic_template_type (type0
);
7906 if (templ_type
!= NULL
)
7907 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
7908 else if (variant_field_index (type0
) >= 0)
7910 if (dval
== NULL
&& valaddr
== NULL
&& address
== 0)
7912 return to_record_with_fixed_variant_part (type0
, valaddr
, address
,
7917 TYPE_FLAGS (type0
) |= TYPE_FLAG_FIXED_INSTANCE
;
7923 /* An ordinary record type (with fixed-length fields) that describes
7924 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
7925 union type. Any necessary discriminants' values should be in DVAL,
7926 a record value. That is, this routine selects the appropriate
7927 branch of the union at ADDR according to the discriminant value
7928 indicated in the union's type name. */
7930 static struct type
*
7931 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
7932 CORE_ADDR address
, struct value
*dval
)
7935 struct type
*templ_type
;
7936 struct type
*var_type
;
7938 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
7939 var_type
= TYPE_TARGET_TYPE (var_type0
);
7941 var_type
= var_type0
;
7943 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
7945 if (templ_type
!= NULL
)
7946 var_type
= templ_type
;
7949 ada_which_variant_applies (var_type
,
7950 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
7953 return empty_record (TYPE_OBJFILE (var_type
));
7954 else if (is_dynamic_field (var_type
, which
))
7955 return to_fixed_record_type
7956 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
7957 valaddr
, address
, dval
);
7958 else if (variant_field_index (TYPE_FIELD_TYPE (var_type
, which
)) >= 0)
7960 to_fixed_record_type
7961 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
7963 return TYPE_FIELD_TYPE (var_type
, which
);
7966 /* Assuming that TYPE0 is an array type describing the type of a value
7967 at ADDR, and that DVAL describes a record containing any
7968 discriminants used in TYPE0, returns a type for the value that
7969 contains no dynamic components (that is, no components whose sizes
7970 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
7971 true, gives an error message if the resulting type's size is over
7974 static struct type
*
7975 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
7978 struct type
*index_type_desc
;
7979 struct type
*result
;
7981 if (ada_is_packed_array_type (type0
) /* revisit? */
7982 || (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
))
7985 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
7986 if (index_type_desc
== NULL
)
7988 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
7989 /* NOTE: elt_type---the fixed version of elt_type0---should never
7990 depend on the contents of the array in properly constructed
7992 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
7994 if (elt_type0
== elt_type
)
7997 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
7998 elt_type
, TYPE_INDEX_TYPE (type0
));
8003 struct type
*elt_type0
;
8006 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
8007 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
8009 /* NOTE: result---the fixed version of elt_type0---should never
8010 depend on the contents of the array in properly constructed
8012 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
8013 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
8015 struct type
*range_type
=
8016 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
8017 dval
, TYPE_OBJFILE (type0
));
8018 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
8019 result
, range_type
);
8021 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
8022 error ("array type with dynamic size is larger than varsize-limit");
8025 TYPE_FLAGS (result
) |= TYPE_FLAG_FIXED_INSTANCE
;
8030 /* A standard type (containing no dynamically sized components)
8031 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
8032 DVAL describes a record containing any discriminants used in TYPE0,
8033 and may be NULL if there are none, or if the object of type TYPE at
8034 ADDRESS or in VALADDR contains these discriminants. */
8037 ada_to_fixed_type (struct type
*type
, char *valaddr
,
8038 CORE_ADDR address
, struct value
*dval
)
8040 CHECK_TYPEDEF (type
);
8041 switch (TYPE_CODE (type
))
8045 case TYPE_CODE_STRUCT
:
8047 struct type
*static_type
= to_static_fixed_type (type
);
8048 if (ada_is_tagged_type (static_type
, 0))
8050 struct type
*real_type
=
8051 type_from_tag (value_tag_from_contents_and_address (static_type
,
8054 if (real_type
!= NULL
)
8057 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
8059 case TYPE_CODE_ARRAY
:
8060 return to_fixed_array_type (type
, dval
, 1);
8061 case TYPE_CODE_UNION
:
8065 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
8069 /* A standard (static-sized) type corresponding as well as possible to
8070 TYPE0, but based on no runtime data. */
8072 static struct type
*
8073 to_static_fixed_type (struct type
*type0
)
8080 if (TYPE_FLAGS (type0
) & TYPE_FLAG_FIXED_INSTANCE
)
8083 CHECK_TYPEDEF (type0
);
8085 switch (TYPE_CODE (type0
))
8089 case TYPE_CODE_STRUCT
:
8090 type
= dynamic_template_type (type0
);
8092 return template_to_static_fixed_type (type
);
8094 return template_to_static_fixed_type (type0
);
8095 case TYPE_CODE_UNION
:
8096 type
= ada_find_parallel_type (type0
, "___XVU");
8098 return template_to_static_fixed_type (type
);
8100 return template_to_static_fixed_type (type0
);
8104 /* A static approximation of TYPE with all type wrappers removed. */
8106 static struct type
*
8107 static_unwrap_type (struct type
*type
)
8109 if (ada_is_aligner_type (type
))
8111 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
8112 if (ada_type_name (type1
) == NULL
)
8113 TYPE_NAME (type1
) = ada_type_name (type
);
8115 return static_unwrap_type (type1
);
8119 struct type
*raw_real_type
= ada_get_base_type (type
);
8120 if (raw_real_type
== type
)
8123 return to_static_fixed_type (raw_real_type
);
8127 /* In some cases, incomplete and private types require
8128 cross-references that are not resolved as records (for example,
8130 type FooP is access Foo;
8132 type Foo is array ...;
8133 ). In these cases, since there is no mechanism for producing
8134 cross-references to such types, we instead substitute for FooP a
8135 stub enumeration type that is nowhere resolved, and whose tag is
8136 the name of the actual type. Call these types "non-record stubs". */
8138 /* A type equivalent to TYPE that is not a non-record stub, if one
8139 exists, otherwise TYPE. */
8142 ada_completed_type (struct type
*type
)
8144 CHECK_TYPEDEF (type
);
8145 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
8146 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
8147 || TYPE_TAG_NAME (type
) == NULL
)
8151 char *name
= TYPE_TAG_NAME (type
);
8152 struct type
*type1
= ada_find_any_type (name
);
8153 return (type1
== NULL
) ? type
: type1
;
8157 /* A value representing the data at VALADDR/ADDRESS as described by
8158 type TYPE0, but with a standard (static-sized) type that correctly
8159 describes it. If VAL0 is not NULL and TYPE0 already is a standard
8160 type, then return VAL0 [this feature is simply to avoid redundant
8161 creation of struct values]. */
8163 static struct value
*
8164 ada_to_fixed_value_create (struct type
*type0
, CORE_ADDR address
,
8167 struct type
*type
= ada_to_fixed_type (type0
, 0, address
, NULL
);
8168 if (type
== type0
&& val0
!= NULL
)
8171 return value_from_contents_and_address (type
, 0, address
);
8174 /* A value representing VAL, but with a standard (static-sized) type
8175 that correctly describes it. Does not necessarily create a new
8178 static struct value
*
8179 ada_to_fixed_value (struct value
*val
)
8181 return ada_to_fixed_value_create (VALUE_TYPE (val
),
8182 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
8186 /* If the PC is pointing inside a function prologue, then re-adjust it
8187 past this prologue. */
8190 adjust_pc_past_prologue (CORE_ADDR
*pc
)
8192 struct symbol
*func_sym
= find_pc_function (*pc
);
8196 const struct symtab_and_line sal
=
8197 find_function_start_sal (func_sym
, 1);
8204 /* A value representing VAL, but with a standard (static-sized) type
8205 chosen to approximate the real type of VAL as well as possible, but
8206 without consulting any runtime values. For Ada dynamic-sized
8207 types, therefore, the type of the result is likely to be inaccurate. */
8210 ada_to_static_fixed_value (struct value
*val
)
8213 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
8214 if (type
== VALUE_TYPE (val
))
8217 return coerce_unspec_val_to_type (val
, type
);
8223 /* Table mapping attribute numbers to names.
8224 NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h. */
8226 static const char *attribute_names
[] = {
8244 ada_attribute_name (enum exp_opcode n
)
8246 if (n
>= OP_ATR_FIRST
&& n
<= (int) OP_ATR_VAL
)
8247 return attribute_names
[n
- OP_ATR_FIRST
+ 1];
8249 return attribute_names
[0];
8252 /* Evaluate the 'POS attribute applied to ARG. */
8255 pos_atr (struct value
*arg
)
8257 struct type
*type
= VALUE_TYPE (arg
);
8259 if (!discrete_type_p (type
))
8260 error ("'POS only defined on discrete types");
8262 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8265 LONGEST v
= value_as_long (arg
);
8267 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
8269 if (v
== TYPE_FIELD_BITPOS (type
, i
))
8272 error ("enumeration value is invalid: can't find 'POS");
8275 return value_as_long (arg
);
8278 static struct value
*
8279 value_pos_atr (struct value
*arg
)
8281 return value_from_longest (builtin_type_ada_int
, pos_atr (arg
));
8284 /* Evaluate the TYPE'VAL attribute applied to ARG. */
8286 static struct value
*
8287 value_val_atr (struct type
*type
, struct value
*arg
)
8289 if (!discrete_type_p (type
))
8290 error ("'VAL only defined on discrete types");
8291 if (!integer_type_p (VALUE_TYPE (arg
)))
8292 error ("'VAL requires integral argument");
8294 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
8296 long pos
= value_as_long (arg
);
8297 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
8298 error ("argument to 'VAL out of range");
8299 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
8302 return value_from_longest (type
, value_as_long (arg
));
8308 /* True if TYPE appears to be an Ada character type.
8309 [At the moment, this is true only for Character and Wide_Character;
8310 It is a heuristic test that could stand improvement]. */
8313 ada_is_character_type (struct type
*type
)
8315 const char *name
= ada_type_name (type
);
8318 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
8319 || TYPE_CODE (type
) == TYPE_CODE_INT
8320 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
8321 && (strcmp (name
, "character") == 0
8322 || strcmp (name
, "wide_character") == 0
8323 || strcmp (name
, "unsigned char") == 0);
8326 /* True if TYPE appears to be an Ada string type. */
8329 ada_is_string_type (struct type
*type
)
8331 CHECK_TYPEDEF (type
);
8333 && TYPE_CODE (type
) != TYPE_CODE_PTR
8334 && (ada_is_simple_array_type (type
)
8335 || ada_is_array_descriptor_type (type
))
8336 && ada_array_arity (type
) == 1)
8338 struct type
*elttype
= ada_array_element_type (type
, 1);
8340 return ada_is_character_type (elttype
);
8347 /* True if TYPE is a struct type introduced by the compiler to force the
8348 alignment of a value. Such types have a single field with a
8349 distinctive name. */
8352 ada_is_aligner_type (struct type
*type
)
8354 CHECK_TYPEDEF (type
);
8355 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
8356 && TYPE_NFIELDS (type
) == 1
8357 && strcmp (TYPE_FIELD_NAME (type
, 0), "F") == 0);
8360 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
8361 the parallel type. */
8364 ada_get_base_type (struct type
*raw_type
)
8366 struct type
*real_type_namer
;
8367 struct type
*raw_real_type
;
8369 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
8372 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
8373 if (real_type_namer
== NULL
8374 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
8375 || TYPE_NFIELDS (real_type_namer
) != 1)
8378 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
8379 if (raw_real_type
== NULL
)
8382 return raw_real_type
;
8385 /* The type of value designated by TYPE, with all aligners removed. */
8388 ada_aligned_type (struct type
*type
)
8390 if (ada_is_aligner_type (type
))
8391 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
8393 return ada_get_base_type (type
);
8397 /* The address of the aligned value in an object at address VALADDR
8398 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
8401 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
8403 if (ada_is_aligner_type (type
))
8404 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
8406 TYPE_FIELD_BITPOS (type
,
8407 0) / TARGET_CHAR_BIT
);
8414 /* The printed representation of an enumeration literal with encoded
8415 name NAME. The value is good to the next call of ada_enum_name. */
8417 ada_enum_name (const char *name
)
8419 static char *result
;
8420 static size_t result_len
= 0;
8423 /* First, unqualify the enumeration name:
8424 1. Search for the last '.' character. If we find one, then skip
8425 all the preceeding characters, the unqualified name starts
8426 right after that dot.
8427 2. Otherwise, we may be debugging on a target where the compiler
8428 translates dots into "__". Search forward for double underscores,
8429 but stop searching when we hit an overloading suffix, which is
8430 of the form "__" followed by digits. */
8432 if ((tmp
= strrchr (name
, '.')) != NULL
)
8436 while ((tmp
= strstr (name
, "__")) != NULL
)
8438 if (isdigit (tmp
[2]))
8448 if (name
[1] == 'U' || name
[1] == 'W')
8450 if (sscanf (name
+ 2, "%x", &v
) != 1)
8456 GROW_VECT (result
, result_len
, 16);
8457 if (isascii (v
) && isprint (v
))
8458 sprintf (result
, "'%c'", v
);
8459 else if (name
[1] == 'U')
8460 sprintf (result
, "[\"%02x\"]", v
);
8462 sprintf (result
, "[\"%04x\"]", v
);
8468 if ((tmp
= strstr (name
, "__")) != NULL
8469 || (tmp
= strstr (name
, "$")) != NULL
)
8471 GROW_VECT (result
, result_len
, tmp
- name
+ 1);
8472 strncpy (result
, name
, tmp
- name
);
8473 result
[tmp
- name
] = '\0';
8481 static struct value
*
8482 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
8485 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
8486 (expect_type
, exp
, pos
, noside
);
8489 /* Evaluate the subexpression of EXP starting at *POS as for
8490 evaluate_type, updating *POS to point just past the evaluated
8493 static struct value
*
8494 evaluate_subexp_type (struct expression
*exp
, int *pos
)
8496 return (*exp
->language_defn
->la_exp_desc
->evaluate_exp
)
8497 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
8500 /* If VAL is wrapped in an aligner or subtype wrapper, return the
8503 static struct value
*
8504 unwrap_value (struct value
*val
)
8506 struct type
*type
= check_typedef (VALUE_TYPE (val
));
8507 if (ada_is_aligner_type (type
))
8509 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
8510 NULL
, "internal structure");
8511 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
8512 if (ada_type_name (val_type
) == NULL
)
8513 TYPE_NAME (val_type
) = ada_type_name (type
);
8515 return unwrap_value (v
);
8519 struct type
*raw_real_type
=
8520 ada_completed_type (ada_get_base_type (type
));
8522 if (type
== raw_real_type
)
8526 coerce_unspec_val_to_type
8527 (val
, ada_to_fixed_type (raw_real_type
, 0,
8528 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
8533 static struct value
*
8534 cast_to_fixed (struct type
*type
, struct value
*arg
)
8538 if (type
== VALUE_TYPE (arg
))
8540 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
8541 val
= ada_float_to_fixed (type
,
8542 ada_fixed_to_float (VALUE_TYPE (arg
),
8543 value_as_long (arg
)));
8547 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
8548 val
= ada_float_to_fixed (type
, argd
);
8551 return value_from_longest (type
, val
);
8554 static struct value
*
8555 cast_from_fixed_to_double (struct value
*arg
)
8557 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
8558 value_as_long (arg
));
8559 return value_from_double (builtin_type_double
, val
);
8562 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
8563 return the converted value. */
8565 static struct value
*
8566 coerce_for_assign (struct type
*type
, struct value
*val
)
8568 struct type
*type2
= VALUE_TYPE (val
);
8572 CHECK_TYPEDEF (type2
);
8573 CHECK_TYPEDEF (type
);
8575 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
8576 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8578 val
= ada_value_ind (val
);
8579 type2
= VALUE_TYPE (val
);
8582 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
8583 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
8585 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
8586 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
8587 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
8588 error ("Incompatible types in assignment");
8589 VALUE_TYPE (val
) = type
;
8594 static struct value
*
8595 ada_value_binop (struct value
*arg1
, struct value
*arg2
, enum exp_opcode op
)
8598 struct type
*type1
, *type2
;
8603 type1
= base_type (check_typedef (VALUE_TYPE (arg1
)));
8604 type2
= base_type (check_typedef (VALUE_TYPE (arg2
)));
8606 if (TYPE_CODE (type1
) != TYPE_CODE_INT
8607 || TYPE_CODE (type2
) != TYPE_CODE_INT
)
8608 return value_binop (arg1
, arg2
, op
);
8617 return value_binop (arg1
, arg2
, op
);
8620 v2
= value_as_long (arg2
);
8622 error ("second operand of %s must not be zero.", op_string (op
));
8624 if (TYPE_UNSIGNED (type1
) || op
== BINOP_MOD
)
8625 return value_binop (arg1
, arg2
, op
);
8627 v1
= value_as_long (arg1
);
8632 if (!TRUNCATION_TOWARDS_ZERO
&& v1
* (v1
% v2
) < 0)
8633 v
+= v
> 0 ? -1 : 1;
8641 /* Should not reach this point. */
8645 val
= allocate_value (type1
);
8646 store_unsigned_integer (VALUE_CONTENTS_RAW (val
),
8647 TYPE_LENGTH (VALUE_TYPE (val
)), v
);
8652 ada_value_equal (struct value
*arg1
, struct value
*arg2
)
8654 if (ada_is_direct_array_type (VALUE_TYPE (arg1
))
8655 || ada_is_direct_array_type (VALUE_TYPE (arg2
)))
8657 arg1
= ada_coerce_to_simple_array (arg1
);
8658 arg2
= ada_coerce_to_simple_array (arg2
);
8659 if (TYPE_CODE (VALUE_TYPE (arg1
)) != TYPE_CODE_ARRAY
8660 || TYPE_CODE (VALUE_TYPE (arg2
)) != TYPE_CODE_ARRAY
)
8661 error ("Attempt to compare array with non-array");
8662 /* FIXME: The following works only for types whose
8663 representations use all bits (no padding or undefined bits)
8664 and do not have user-defined equality. */
8666 TYPE_LENGTH (VALUE_TYPE (arg1
)) == TYPE_LENGTH (VALUE_TYPE (arg2
))
8667 && memcmp (VALUE_CONTENTS (arg1
), VALUE_CONTENTS (arg2
),
8668 TYPE_LENGTH (VALUE_TYPE (arg1
))) == 0;
8670 return value_equal (arg1
, arg2
);
8674 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
8675 int *pos
, enum noside noside
)
8678 int tem
, tem2
, tem3
;
8680 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
8683 struct value
**argvec
;
8687 op
= exp
->elts
[pc
].opcode
;
8694 unwrap_value (evaluate_subexp_standard
8695 (expect_type
, exp
, pos
, noside
));
8699 struct value
*result
;
8701 result
= evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
8702 /* The result type will have code OP_STRING, bashed there from
8703 OP_ARRAY. Bash it back. */
8704 if (TYPE_CODE (VALUE_TYPE (result
)) == TYPE_CODE_STRING
)
8705 TYPE_CODE (VALUE_TYPE (result
)) = TYPE_CODE_ARRAY
;
8711 type
= exp
->elts
[pc
+ 1].type
;
8712 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
8713 if (noside
== EVAL_SKIP
)
8715 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
8717 if (ada_is_fixed_point_type (type
))
8718 arg1
= cast_to_fixed (type
, arg1
);
8719 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8720 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
8721 else if (VALUE_LVAL (arg1
) == lval_memory
)
8723 /* This is in case of the really obscure (and undocumented,
8724 but apparently expected) case of (Foo) Bar.all, where Bar
8725 is an integer constant and Foo is a dynamic-sized type.
8726 If we don't do this, ARG1 will simply be relabeled with
8728 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8729 return value_zero (to_static_fixed_type (type
), not_lval
);
8731 ada_to_fixed_value_create
8732 (type
, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
8735 arg1
= value_cast (type
, arg1
);
8741 type
= exp
->elts
[pc
+ 1].type
;
8742 return ada_evaluate_subexp (type
, exp
, pos
, noside
);
8745 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8746 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
8747 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
8749 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8750 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
8751 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8753 ("Fixed-point values must be assigned to fixed-point variables");
8755 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
8756 return ada_value_assign (arg1
, arg2
);
8759 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8760 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8761 if (noside
== EVAL_SKIP
)
8763 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
8764 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8765 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
8766 error ("Operands of fixed-point addition must have the same type");
8767 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
8770 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8771 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
8772 if (noside
== EVAL_SKIP
)
8774 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
8775 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8776 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
8777 error ("Operands of fixed-point subtraction must have the same type");
8778 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
8782 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8783 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8784 if (noside
== EVAL_SKIP
)
8786 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8787 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8788 return value_zero (VALUE_TYPE (arg1
), not_lval
);
8791 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8792 arg1
= cast_from_fixed_to_double (arg1
);
8793 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
8794 arg2
= cast_from_fixed_to_double (arg2
);
8795 return ada_value_binop (arg1
, arg2
, op
);
8800 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8801 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8802 if (noside
== EVAL_SKIP
)
8804 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
8805 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
8806 return value_zero (VALUE_TYPE (arg1
), not_lval
);
8808 return ada_value_binop (arg1
, arg2
, op
);
8811 case BINOP_NOTEQUAL
:
8812 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8813 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
8814 if (noside
== EVAL_SKIP
)
8816 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8819 tem
= ada_value_equal (arg1
, arg2
);
8820 if (op
== BINOP_NOTEQUAL
)
8822 return value_from_longest (LA_BOOL_TYPE
, (LONGEST
) tem
);
8825 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8826 if (noside
== EVAL_SKIP
)
8828 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
8829 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
8831 return value_neg (arg1
);
8835 if (noside
== EVAL_SKIP
)
8840 else if (SYMBOL_DOMAIN (exp
->elts
[pc
+ 2].symbol
) == UNDEF_DOMAIN
)
8841 /* Only encountered when an unresolved symbol occurs in a
8842 context other than a function call, in which case, it is
8844 error ("Unexpected unresolved symbol, %s, during evaluation",
8845 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 2].symbol
));
8846 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8850 (to_static_fixed_type
8851 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
8857 unwrap_value (evaluate_subexp_standard
8858 (expect_type
, exp
, pos
, noside
));
8859 return ada_to_fixed_value (arg1
);
8865 /* Allocate arg vector, including space for the function to be
8866 called in argvec[0] and a terminating NULL. */
8867 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
8869 (struct value
**) alloca (sizeof (struct value
*) * (nargs
+ 2));
8871 if (exp
->elts
[*pos
].opcode
== OP_VAR_VALUE
8872 && SYMBOL_DOMAIN (exp
->elts
[pc
+ 5].symbol
) == UNDEF_DOMAIN
)
8873 error ("Unexpected unresolved symbol, %s, during evaluation",
8874 SYMBOL_PRINT_NAME (exp
->elts
[pc
+ 5].symbol
));
8877 for (tem
= 0; tem
<= nargs
; tem
+= 1)
8878 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8881 if (noside
== EVAL_SKIP
)
8885 if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec
[0]))))
8886 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
8887 else if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
8888 || (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_ARRAY
8889 && VALUE_LVAL (argvec
[0]) == lval_memory
))
8890 argvec
[0] = value_addr (argvec
[0]);
8892 type
= check_typedef (VALUE_TYPE (argvec
[0]));
8893 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
8895 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
8897 case TYPE_CODE_FUNC
:
8898 type
= check_typedef (TYPE_TARGET_TYPE (type
));
8900 case TYPE_CODE_ARRAY
:
8902 case TYPE_CODE_STRUCT
:
8903 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
8904 argvec
[0] = ada_value_ind (argvec
[0]);
8905 type
= check_typedef (TYPE_TARGET_TYPE (type
));
8908 error ("cannot subscript or call something of type `%s'",
8909 ada_type_name (VALUE_TYPE (argvec
[0])));
8914 switch (TYPE_CODE (type
))
8916 case TYPE_CODE_FUNC
:
8917 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8918 return allocate_value (TYPE_TARGET_TYPE (type
));
8919 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
8920 case TYPE_CODE_STRUCT
:
8924 /* Make sure to use the parallel ___XVS type if any.
8925 Otherwise, we won't be able to find the array arity
8926 and element type. */
8927 type
= ada_get_base_type (type
);
8929 arity
= ada_array_arity (type
);
8930 type
= ada_array_element_type (type
, nargs
);
8932 error ("cannot subscript or call a record");
8934 error ("wrong number of subscripts; expecting %d", arity
);
8935 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8936 return allocate_value (ada_aligned_type (type
));
8938 unwrap_value (ada_value_subscript
8939 (argvec
[0], nargs
, argvec
+ 1));
8941 case TYPE_CODE_ARRAY
:
8942 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8944 type
= ada_array_element_type (type
, nargs
);
8946 error ("element type of array unknown");
8948 return allocate_value (ada_aligned_type (type
));
8951 unwrap_value (ada_value_subscript
8952 (ada_coerce_to_simple_array (argvec
[0]),
8953 nargs
, argvec
+ 1));
8954 case TYPE_CODE_PTR
: /* Pointer to array */
8955 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
8956 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
8958 type
= ada_array_element_type (type
, nargs
);
8960 error ("element type of array unknown");
8962 return allocate_value (ada_aligned_type (type
));
8965 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
8966 nargs
, argvec
+ 1));
8969 error ("Internal error in evaluate_subexp");
8974 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8975 struct value
*low_bound_val
=
8976 evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
8977 LONGEST low_bound
= pos_atr (low_bound_val
);
8979 = pos_atr (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
8980 if (noside
== EVAL_SKIP
)
8983 /* If this is a reference type or a pointer type, and
8984 the target type has an XVS parallel type, then get
8985 the real target type. */
8986 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
8987 || TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
)
8988 TYPE_TARGET_TYPE (VALUE_TYPE (array
)) =
8989 ada_get_base_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)));
8991 /* If this is a reference to an aligner type, then remove all
8993 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
8994 && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
))))
8995 TYPE_TARGET_TYPE (VALUE_TYPE (array
)) =
8996 ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)));
8998 if (ada_is_packed_array_type (VALUE_TYPE (array
)))
8999 error ("cannot slice a packed array");
9001 /* If this is a reference to an array or an array lvalue,
9002 convert to a pointer. */
9003 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
9004 || (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_ARRAY
9005 && VALUE_LVAL (array
) == lval_memory
))
9006 array
= value_addr (array
);
9008 if (noside
== EVAL_AVOID_SIDE_EFFECTS
9009 && ada_is_array_descriptor_type
9010 (check_typedef (VALUE_TYPE (array
))))
9012 /* Try dereferencing the array, in case it is an access
9014 struct type
*arrType
= ada_type_of_array (array
, 0);
9015 if (arrType
!= NULL
)
9016 array
= value_at_lazy (arrType
, 0, NULL
);
9019 array
= ada_coerce_to_simple_array_ptr (array
);
9021 /* When EVAL_AVOID_SIDE_EFFECTS, we may get the bounds wrong,
9022 but only in contexts where the value is not being requested
9024 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
)
9026 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9027 return ada_value_ind (array
);
9028 else if (high_bound
< low_bound
)
9029 return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
9033 struct type
*arr_type0
=
9034 to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array
)),
9036 struct value
*item0
=
9037 ada_value_ptr_subscript (array
, arr_type0
, 1,
9039 struct value
*slice
=
9040 value_repeat (item0
, high_bound
- low_bound
+ 1);
9041 struct type
*arr_type1
= VALUE_TYPE (slice
);
9042 TYPE_LOW_BOUND (TYPE_INDEX_TYPE (arr_type1
)) = low_bound
;
9043 TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (arr_type1
)) += low_bound
;
9047 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9049 else if (high_bound
< low_bound
)
9050 return empty_array (VALUE_TYPE (array
), low_bound
);
9052 return value_slice (array
, low_bound
, high_bound
- low_bound
+ 1);
9057 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9058 type
= exp
->elts
[pc
+ 1].type
;
9060 if (noside
== EVAL_SKIP
)
9063 switch (TYPE_CODE (type
))
9066 lim_warning ("Membership test incompletely implemented; "
9067 "always returns true", 0);
9068 return value_from_longest (builtin_type_int
, (LONGEST
) 1);
9070 case TYPE_CODE_RANGE
:
9071 arg2
= value_from_longest (builtin_type_int
, TYPE_LOW_BOUND (type
));
9072 arg3
= value_from_longest (builtin_type_int
,
9073 TYPE_HIGH_BOUND (type
));
9075 value_from_longest (builtin_type_int
,
9076 (value_less (arg1
, arg3
)
9077 || value_equal (arg1
, arg3
))
9078 && (value_less (arg2
, arg1
)
9079 || value_equal (arg2
, arg1
)));
9082 case BINOP_IN_BOUNDS
:
9084 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9085 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9087 if (noside
== EVAL_SKIP
)
9090 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9091 return value_zero (builtin_type_int
, not_lval
);
9093 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9095 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg2
)))
9096 error ("invalid dimension number to '%s", "range");
9098 arg3
= ada_array_bound (arg2
, tem
, 1);
9099 arg2
= ada_array_bound (arg2
, tem
, 0);
9102 value_from_longest (builtin_type_int
,
9103 (value_less (arg1
, arg3
)
9104 || value_equal (arg1
, arg3
))
9105 && (value_less (arg2
, arg1
)
9106 || value_equal (arg2
, arg1
)));
9108 case TERNOP_IN_RANGE
:
9109 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9110 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9111 arg3
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9113 if (noside
== EVAL_SKIP
)
9117 value_from_longest (builtin_type_int
,
9118 (value_less (arg1
, arg3
)
9119 || value_equal (arg1
, arg3
))
9120 && (value_less (arg2
, arg1
)
9121 || value_equal (arg2
, arg1
)));
9127 struct type
*type_arg
;
9128 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9130 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9132 type_arg
= exp
->elts
[pc
+ 2].type
;
9136 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9140 if (exp
->elts
[*pos
].opcode
!= OP_LONG
)
9141 error ("illegal operand to '%s", ada_attribute_name (op
));
9142 tem
= longest_to_int (exp
->elts
[*pos
+ 2].longconst
);
9145 if (noside
== EVAL_SKIP
)
9148 if (type_arg
== NULL
)
9150 arg1
= ada_coerce_ref (arg1
);
9152 if (ada_is_packed_array_type (VALUE_TYPE (arg1
)))
9153 arg1
= ada_coerce_to_simple_array (arg1
);
9155 if (tem
< 1 || tem
> ada_array_arity (VALUE_TYPE (arg1
)))
9156 error ("invalid dimension number to '%s",
9157 ada_attribute_name (op
));
9159 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9161 type
= ada_index_type (VALUE_TYPE (arg1
), tem
);
9164 ("attempt to take bound of something that is not an array");
9165 return allocate_value (type
);
9170 default: /* Should never happen. */
9171 error ("unexpected attribute encountered");
9173 return ada_array_bound (arg1
, tem
, 0);
9175 return ada_array_bound (arg1
, tem
, 1);
9177 return ada_array_length (arg1
, tem
);
9180 else if (discrete_type_p (type_arg
))
9182 struct type
*range_type
;
9183 char *name
= ada_type_name (type_arg
);
9185 if (name
!= NULL
&& TYPE_CODE (type_arg
) != TYPE_CODE_ENUM
)
9187 to_fixed_range_type (name
, NULL
, TYPE_OBJFILE (type_arg
));
9188 if (range_type
== NULL
)
9189 range_type
= type_arg
;
9193 error ("unexpected attribute encountered");
9195 return discrete_type_low_bound (range_type
);
9197 return discrete_type_high_bound (range_type
);
9199 error ("the 'length attribute applies only to array types");
9202 else if (TYPE_CODE (type_arg
) == TYPE_CODE_FLT
)
9203 error ("unimplemented type attribute");
9208 if (ada_is_packed_array_type (type_arg
))
9209 type_arg
= decode_packed_array_type (type_arg
);
9211 if (tem
< 1 || tem
> ada_array_arity (type_arg
))
9212 error ("invalid dimension number to '%s",
9213 ada_attribute_name (op
));
9215 type
= ada_index_type (type_arg
, tem
);
9218 ("attempt to take bound of something that is not an array");
9219 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9220 return allocate_value (type
);
9225 error ("unexpected attribute encountered");
9227 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9228 return value_from_longest (type
, low
);
9230 high
= ada_array_bound_from_type (type_arg
, tem
, 1, &type
);
9231 return value_from_longest (type
, high
);
9233 low
= ada_array_bound_from_type (type_arg
, tem
, 0, &type
);
9234 high
= ada_array_bound_from_type (type_arg
, tem
, 1, NULL
);
9235 return value_from_longest (type
, high
- low
+ 1);
9241 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9242 if (noside
== EVAL_SKIP
)
9245 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9246 return value_zero (ada_tag_type (arg1
), not_lval
);
9248 return ada_value_tag (arg1
);
9252 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9253 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9254 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9255 if (noside
== EVAL_SKIP
)
9257 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9258 return value_zero (VALUE_TYPE (arg1
), not_lval
);
9260 return value_binop (arg1
, arg2
,
9261 op
== OP_ATR_MIN
? BINOP_MIN
: BINOP_MAX
);
9263 case OP_ATR_MODULUS
:
9265 struct type
*type_arg
= exp
->elts
[pc
+ 2].type
;
9266 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9268 if (noside
== EVAL_SKIP
)
9271 if (!ada_is_modular_type (type_arg
))
9272 error ("'modulus must be applied to modular type");
9274 return value_from_longest (TYPE_TARGET_TYPE (type_arg
),
9275 ada_modulus (type_arg
));
9280 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9281 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9282 if (noside
== EVAL_SKIP
)
9284 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9285 return value_zero (builtin_type_ada_int
, not_lval
);
9287 return value_pos_atr (arg1
);
9290 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9291 if (noside
== EVAL_SKIP
)
9293 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9294 return value_zero (builtin_type_ada_int
, not_lval
);
9296 return value_from_longest (builtin_type_ada_int
,
9298 * TYPE_LENGTH (VALUE_TYPE (arg1
)));
9301 evaluate_subexp (NULL_TYPE
, exp
, pos
, EVAL_SKIP
);
9302 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9303 type
= exp
->elts
[pc
+ 2].type
;
9304 if (noside
== EVAL_SKIP
)
9306 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9307 return value_zero (type
, not_lval
);
9309 return value_val_atr (type
, arg1
);
9312 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9313 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9314 if (noside
== EVAL_SKIP
)
9316 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9317 return value_zero (VALUE_TYPE (arg1
), not_lval
);
9319 return value_binop (arg1
, arg2
, op
);
9322 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9323 if (noside
== EVAL_SKIP
)
9329 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9330 if (noside
== EVAL_SKIP
)
9332 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
9333 return value_neg (arg1
);
9338 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
9339 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
9340 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
9341 if (noside
== EVAL_SKIP
)
9343 type
= check_typedef (VALUE_TYPE (arg1
));
9344 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9346 if (ada_is_array_descriptor_type (type
))
9347 /* GDB allows dereferencing GNAT array descriptors. */
9349 struct type
*arrType
= ada_type_of_array (arg1
, 0);
9350 if (arrType
== NULL
)
9351 error ("Attempt to dereference null array pointer.");
9352 return value_at_lazy (arrType
, 0, NULL
);
9354 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
9355 || TYPE_CODE (type
) == TYPE_CODE_REF
9356 /* In C you can dereference an array to get the 1st elt. */
9357 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
9360 (to_static_fixed_type
9361 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
9363 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
9364 /* GDB allows dereferencing an int. */
9365 return value_zero (builtin_type_int
, lval_memory
);
9367 error ("Attempt to take contents of a non-pointer value.");
9369 arg1
= ada_coerce_ref (arg1
); /* FIXME: What is this for?? */
9370 type
= check_typedef (VALUE_TYPE (arg1
));
9372 if (ada_is_array_descriptor_type (type
))
9373 /* GDB allows dereferencing GNAT array descriptors. */
9374 return ada_coerce_to_simple_array (arg1
);
9376 return ada_value_ind (arg1
);
9378 case STRUCTOP_STRUCT
:
9379 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
9380 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
9381 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
9382 if (noside
== EVAL_SKIP
)
9384 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9386 struct type
*type1
= VALUE_TYPE (arg1
);
9387 if (ada_is_tagged_type (type1
, 1))
9389 type
= ada_lookup_struct_elt_type (type1
,
9390 &exp
->elts
[pc
+ 2].string
,
9393 /* In this case, we assume that the field COULD exist
9394 in some extension of the type. Return an object of
9395 "type" void, which will match any formal
9396 (see ada_type_match). */
9397 return value_zero (builtin_type_void
, lval_memory
);
9401 ada_lookup_struct_elt_type (type1
, &exp
->elts
[pc
+ 2].string
, 1,
9404 return value_zero (ada_aligned_type (type
), lval_memory
);
9408 ada_to_fixed_value (unwrap_value
9409 (ada_value_struct_elt
9410 (arg1
, &exp
->elts
[pc
+ 2].string
, "record")));
9412 /* The value is not supposed to be used. This is here to make it
9413 easier to accommodate expressions that contain types. */
9415 if (noside
== EVAL_SKIP
)
9417 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
9418 return allocate_value (builtin_type_void
);
9420 error ("Attempt to use a type name as an expression");
9424 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
9430 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
9431 type name that encodes the 'small and 'delta information.
9432 Otherwise, return NULL. */
9435 fixed_type_info (struct type
*type
)
9437 const char *name
= ada_type_name (type
);
9438 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
9440 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
9442 const char *tail
= strstr (name
, "___XF_");
9448 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
9449 return fixed_type_info (TYPE_TARGET_TYPE (type
));
9454 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
9457 ada_is_fixed_point_type (struct type
*type
)
9459 return fixed_type_info (type
) != NULL
;
9462 /* Return non-zero iff TYPE represents a System.Address type. */
9465 ada_is_system_address_type (struct type
*type
)
9467 return (TYPE_NAME (type
)
9468 && strcmp (TYPE_NAME (type
), "system__address") == 0);
9471 /* Assuming that TYPE is the representation of an Ada fixed-point
9472 type, return its delta, or -1 if the type is malformed and the
9473 delta cannot be determined. */
9476 ada_delta (struct type
*type
)
9478 const char *encoding
= fixed_type_info (type
);
9481 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
9484 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
9487 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
9488 factor ('SMALL value) associated with the type. */
9491 scaling_factor (struct type
*type
)
9493 const char *encoding
= fixed_type_info (type
);
9494 unsigned long num0
, den0
, num1
, den1
;
9497 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
9502 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
9504 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
9508 /* Assuming that X is the representation of a value of fixed-point
9509 type TYPE, return its floating-point equivalent. */
9512 ada_fixed_to_float (struct type
*type
, LONGEST x
)
9514 return (DOUBLEST
) x
*scaling_factor (type
);
9517 /* The representation of a fixed-point value of type TYPE
9518 corresponding to the value X. */
9521 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
9523 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
9527 /* VAX floating formats */
9529 /* Non-zero iff TYPE represents one of the special VAX floating-point
9533 ada_is_vax_floating_type (struct type
*type
)
9536 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
9539 && (TYPE_CODE (type
) == TYPE_CODE_INT
9540 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
9541 && strncmp (ada_type_name (type
) + name_len
- 6, "___XF", 5) == 0;
9544 /* The type of special VAX floating-point type this is, assuming
9545 ada_is_vax_floating_point. */
9548 ada_vax_float_type_suffix (struct type
*type
)
9550 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
9553 /* A value representing the special debugging function that outputs
9554 VAX floating-point values of the type represented by TYPE. Assumes
9555 ada_is_vax_floating_type (TYPE). */
9558 ada_vax_float_print_function (struct type
*type
)
9560 switch (ada_vax_float_type_suffix (type
))
9563 return get_var_value ("DEBUG_STRING_F", 0);
9565 return get_var_value ("DEBUG_STRING_D", 0);
9567 return get_var_value ("DEBUG_STRING_G", 0);
9569 error ("invalid VAX floating-point type");
9576 /* Scan STR beginning at position K for a discriminant name, and
9577 return the value of that discriminant field of DVAL in *PX. If
9578 PNEW_K is not null, put the position of the character beyond the
9579 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
9580 not alter *PX and *PNEW_K if unsuccessful. */
9583 scan_discrim_bound (char *str
, int k
, struct value
*dval
, LONGEST
* px
,
9586 static char *bound_buffer
= NULL
;
9587 static size_t bound_buffer_len
= 0;
9590 struct value
*bound_val
;
9592 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
9595 pend
= strstr (str
+ k
, "__");
9599 k
+= strlen (bound
);
9603 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
9604 bound
= bound_buffer
;
9605 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
9606 bound
[pend
- (str
+ k
)] = '\0';
9610 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
9611 if (bound_val
== NULL
)
9614 *px
= value_as_long (bound_val
);
9620 /* Value of variable named NAME in the current environment. If
9621 no such variable found, then if ERR_MSG is null, returns 0, and
9622 otherwise causes an error with message ERR_MSG. */
9624 static struct value
*
9625 get_var_value (char *name
, char *err_msg
)
9627 struct ada_symbol_info
*syms
;
9630 nsyms
= ada_lookup_symbol_list (name
, get_selected_block (0), VAR_DOMAIN
,
9635 if (err_msg
== NULL
)
9638 error ("%s", err_msg
);
9641 return value_of_variable (syms
[0].sym
, syms
[0].block
);
9644 /* Value of integer variable named NAME in the current environment. If
9645 no such variable found, returns 0, and sets *FLAG to 0. If
9646 successful, sets *FLAG to 1. */
9649 get_int_var_value (char *name
, int *flag
)
9651 struct value
*var_val
= get_var_value (name
, 0);
9663 return value_as_long (var_val
);
9668 /* Return a range type whose base type is that of the range type named
9669 NAME in the current environment, and whose bounds are calculated
9670 from NAME according to the GNAT range encoding conventions.
9671 Extract discriminant values, if needed, from DVAL. If a new type
9672 must be created, allocate in OBJFILE's space. The bounds
9673 information, in general, is encoded in NAME, the base type given in
9674 the named range type. */
9676 static struct type
*
9677 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
9679 struct type
*raw_type
= ada_find_any_type (name
);
9680 struct type
*base_type
;
9683 if (raw_type
== NULL
)
9684 base_type
= builtin_type_int
;
9685 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
9686 base_type
= TYPE_TARGET_TYPE (raw_type
);
9688 base_type
= raw_type
;
9690 subtype_info
= strstr (name
, "___XD");
9691 if (subtype_info
== NULL
)
9695 static char *name_buf
= NULL
;
9696 static size_t name_len
= 0;
9697 int prefix_len
= subtype_info
- name
;
9703 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
9704 strncpy (name_buf
, name
, prefix_len
);
9705 name_buf
[prefix_len
] = '\0';
9708 bounds_str
= strchr (subtype_info
, '_');
9711 if (*subtype_info
== 'L')
9713 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
9714 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
9716 if (bounds_str
[n
] == '_')
9718 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
9725 strcpy (name_buf
+ prefix_len
, "___L");
9726 L
= get_int_var_value (name_buf
, &ok
);
9729 lim_warning ("Unknown lower bound, using 1.", 1);
9734 if (*subtype_info
== 'U')
9736 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
9737 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
9743 strcpy (name_buf
+ prefix_len
, "___U");
9744 U
= get_int_var_value (name_buf
, &ok
);
9747 lim_warning ("Unknown upper bound, using %ld.", (long) L
);
9752 if (objfile
== NULL
)
9753 objfile
= TYPE_OBJFILE (base_type
);
9754 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
9755 TYPE_NAME (type
) = name
;
9760 /* True iff NAME is the name of a range type. */
9763 ada_is_range_type_name (const char *name
)
9765 return (name
!= NULL
&& strstr (name
, "___XD"));
9771 /* True iff TYPE is an Ada modular type. */
9774 ada_is_modular_type (struct type
*type
)
9776 struct type
*subranged_type
= base_type (type
);
9778 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
9779 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
9780 && TYPE_UNSIGNED (subranged_type
));
9783 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
9786 ada_modulus (struct type
* type
)
9788 return TYPE_HIGH_BOUND (type
) + 1;
9792 /* Information about operators given special treatment in functions
9794 /* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
9796 #define ADA_OPERATORS \
9797 OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
9798 OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
9799 OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
9800 OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
9801 OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
9802 OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
9803 OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
9804 OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
9805 OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
9806 OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
9807 OP_DEFN (OP_ATR_POS, 1, 2, 0) \
9808 OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
9809 OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
9810 OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
9811 OP_DEFN (UNOP_QUAL, 3, 1, 0) \
9812 OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
9815 ada_operator_length (struct expression
*exp
, int pc
, int *oplenp
, int *argsp
)
9817 switch (exp
->elts
[pc
- 1].opcode
)
9820 operator_length_standard (exp
, pc
, oplenp
, argsp
);
9823 #define OP_DEFN(op, len, args, binop) \
9824 case op: *oplenp = len; *argsp = args; break;
9831 ada_op_name (enum exp_opcode opcode
)
9836 return op_name_standard (opcode
);
9837 #define OP_DEFN(op, len, args, binop) case op: return #op;
9843 /* As for operator_length, but assumes PC is pointing at the first
9844 element of the operator, and gives meaningful results only for the
9845 Ada-specific operators. */
9848 ada_forward_operator_length (struct expression
*exp
, int pc
,
9849 int *oplenp
, int *argsp
)
9851 switch (exp
->elts
[pc
].opcode
)
9854 *oplenp
= *argsp
= 0;
9856 #define OP_DEFN(op, len, args, binop) \
9857 case op: *oplenp = len; *argsp = args; break;
9864 ada_dump_subexp_body (struct expression
*exp
, struct ui_file
*stream
, int elt
)
9866 enum exp_opcode op
= exp
->elts
[elt
].opcode
;
9871 ada_forward_operator_length (exp
, elt
, &oplen
, &nargs
);
9875 /* Ada attributes ('Foo). */
9882 case OP_ATR_MODULUS
:
9891 fprintf_filtered (stream
, "Type @");
9892 gdb_print_host_address (exp
->elts
[pc
+ 1].type
, stream
);
9893 fprintf_filtered (stream
, " (");
9894 type_print (exp
->elts
[pc
+ 1].type
, NULL
, stream
, 0);
9895 fprintf_filtered (stream
, ")");
9897 case BINOP_IN_BOUNDS
:
9898 fprintf_filtered (stream
, " (%d)", (int) exp
->elts
[pc
+ 2].longconst
);
9900 case TERNOP_IN_RANGE
:
9904 return dump_subexp_body_standard (exp
, stream
, elt
);
9908 for (i
= 0; i
< nargs
; i
+= 1)
9909 elt
= dump_subexp (exp
, stream
, elt
);
9914 /* The Ada extension of print_subexp (q.v.). */
9917 ada_print_subexp (struct expression
*exp
, int *pos
,
9918 struct ui_file
*stream
, enum precedence prec
)
9922 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
9924 ada_forward_operator_length (exp
, pc
, &oplen
, &nargs
);
9929 print_subexp_standard (exp
, pos
, stream
, prec
);
9934 fputs_filtered (SYMBOL_NATURAL_NAME (exp
->elts
[pc
+ 2].symbol
), stream
);
9937 case BINOP_IN_BOUNDS
:
9939 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9940 fputs_filtered (" in ", stream
);
9941 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9942 fputs_filtered ("'range", stream
);
9943 if (exp
->elts
[pc
+ 1].longconst
> 1)
9944 fprintf_filtered (stream
, "(%ld)",
9945 (long) exp
->elts
[pc
+ 1].longconst
);
9948 case TERNOP_IN_RANGE
:
9950 if (prec
>= PREC_EQUAL
)
9951 fputs_filtered ("(", stream
);
9952 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9953 fputs_filtered (" in ", stream
);
9954 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
9955 fputs_filtered (" .. ", stream
);
9956 print_subexp (exp
, pos
, stream
, PREC_EQUAL
);
9957 if (prec
>= PREC_EQUAL
)
9958 fputs_filtered (")", stream
);
9967 case OP_ATR_MODULUS
:
9973 if (exp
->elts
[*pos
].opcode
== OP_TYPE
)
9975 if (TYPE_CODE (exp
->elts
[*pos
+ 1].type
) != TYPE_CODE_VOID
)
9976 LA_PRINT_TYPE (exp
->elts
[*pos
+ 1].type
, "", stream
, 0, 0);
9980 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
9981 fprintf_filtered (stream
, "'%s", ada_attribute_name (op
));
9985 for (tem
= 1; tem
< nargs
; tem
+= 1)
9987 fputs_filtered ((tem
== 1) ? " (" : ", ", stream
);
9988 print_subexp (exp
, pos
, stream
, PREC_ABOVE_COMMA
);
9990 fputs_filtered (")", stream
);
9996 type_print (exp
->elts
[pc
+ 1].type
, "", stream
, 0);
9997 fputs_filtered ("'(", stream
);
9998 print_subexp (exp
, pos
, stream
, PREC_PREFIX
);
9999 fputs_filtered (")", stream
);
10002 case UNOP_IN_RANGE
:
10004 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
10005 fputs_filtered (" in ", stream
);
10006 LA_PRINT_TYPE (exp
->elts
[pc
+ 1].type
, "", stream
, 1, 0);
10011 /* Table mapping opcodes into strings for printing operators
10012 and precedences of the operators. */
10014 static const struct op_print ada_op_print_tab
[] = {
10015 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
10016 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
10017 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
10018 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
10019 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
10020 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
10021 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
10022 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
10023 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
10024 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
10025 {">", BINOP_GTR
, PREC_ORDER
, 0},
10026 {"<", BINOP_LESS
, PREC_ORDER
, 0},
10027 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
10028 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
10029 {"+", BINOP_ADD
, PREC_ADD
, 0},
10030 {"-", BINOP_SUB
, PREC_ADD
, 0},
10031 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
10032 {"*", BINOP_MUL
, PREC_MUL
, 0},
10033 {"/", BINOP_DIV
, PREC_MUL
, 0},
10034 {"rem", BINOP_REM
, PREC_MUL
, 0},
10035 {"mod", BINOP_MOD
, PREC_MUL
, 0},
10036 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
10037 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
10038 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
10039 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
10040 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
10041 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
10042 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
10043 {".all", UNOP_IND
, PREC_SUFFIX
, 1},
10044 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1},
10045 {"'size", OP_ATR_SIZE
, PREC_SUFFIX
, 1},
10049 /* Assorted Types and Interfaces */
10051 struct type
*builtin_type_ada_int
;
10052 struct type
*builtin_type_ada_short
;
10053 struct type
*builtin_type_ada_long
;
10054 struct type
*builtin_type_ada_long_long
;
10055 struct type
*builtin_type_ada_char
;
10056 struct type
*builtin_type_ada_float
;
10057 struct type
*builtin_type_ada_double
;
10058 struct type
*builtin_type_ada_long_double
;
10059 struct type
*builtin_type_ada_natural
;
10060 struct type
*builtin_type_ada_positive
;
10061 struct type
*builtin_type_ada_system_address
;
10063 struct type
**const (ada_builtin_types
[]) =
10065 &builtin_type_ada_int
,
10066 &builtin_type_ada_long
,
10067 &builtin_type_ada_short
,
10068 &builtin_type_ada_char
,
10069 &builtin_type_ada_float
,
10070 &builtin_type_ada_double
,
10071 &builtin_type_ada_long_long
,
10072 &builtin_type_ada_long_double
,
10073 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
10074 /* The following types are carried over from C for convenience. */
10076 &builtin_type_long
,
10077 &builtin_type_short
,
10078 &builtin_type_char
,
10079 &builtin_type_float
,
10080 &builtin_type_double
,
10081 &builtin_type_long_long
,
10082 &builtin_type_void
,
10083 &builtin_type_signed_char
,
10084 &builtin_type_unsigned_char
,
10085 &builtin_type_unsigned_short
,
10086 &builtin_type_unsigned_int
,
10087 &builtin_type_unsigned_long
,
10088 &builtin_type_unsigned_long_long
,
10089 &builtin_type_long_double
,
10090 &builtin_type_complex
, &builtin_type_double_complex
, 0};
10092 /* Not really used, but needed in the ada_language_defn. */
10095 emit_char (int c
, struct ui_file
*stream
, int quoter
)
10097 ada_emit_char (c
, stream
, quoter
, 1);
10103 warnings_issued
= 0;
10104 return ada_parse ();
10107 static const struct exp_descriptor ada_exp_descriptor
= {
10109 ada_operator_length
,
10111 ada_dump_subexp_body
,
10112 ada_evaluate_subexp
10115 const struct language_defn ada_language_defn
= {
10116 "ada", /* Language name */
10121 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
10122 that's not quite what this means. */
10125 ada_lookup_minimal_symbol
,
10126 #endif /* GNAT_GDB */
10127 &ada_exp_descriptor
,
10131 ada_printchar
, /* Print a character constant */
10132 ada_printstr
, /* Function to print string constant */
10133 emit_char
, /* Function to print single char (not used) */
10134 ada_create_fundamental_type
, /* Create fundamental type in this language */
10135 ada_print_type
, /* Print a type using appropriate syntax */
10136 ada_val_print
, /* Print a value using appropriate syntax */
10137 ada_value_print
, /* Print a top-level value */
10138 NULL
, /* Language specific skip_trampoline */
10139 NULL
, /* value_of_this */
10140 ada_lookup_symbol_nonlocal
, /* Looking up non-local symbols. */
10141 basic_lookup_transparent_type
, /* lookup_transparent_type */
10142 ada_la_decode
, /* Language specific symbol demangler */
10143 {"", "", "", ""}, /* Binary format info */
10145 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
10146 {"%ld", "", "d", ""}, /* Decimal format info */
10147 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
10149 /* Copied from c-lang.c. */
10150 {"0%lo", "0", "o", ""}, /* Octal format info */
10151 {"%ld", "", "d", ""}, /* Decimal format info */
10152 {"0x%lx", "0x", "x", ""}, /* Hex format info */
10154 ada_op_print_tab
, /* expression operators for printing */
10155 0, /* c-style arrays */
10156 1, /* String lower bound */
10157 &builtin_type_ada_char
,
10158 ada_get_gdb_completer_word_break_characters
,
10160 ada_translate_error_message
, /* Substitute Ada-specific terminology
10161 in errors and warnings. */
10162 #endif /* GNAT_GDB */
10167 build_ada_types (void)
10169 builtin_type_ada_int
=
10170 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10171 0, "integer", (struct objfile
*) NULL
);
10172 builtin_type_ada_long
=
10173 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10174 0, "long_integer", (struct objfile
*) NULL
);
10175 builtin_type_ada_short
=
10176 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10177 0, "short_integer", (struct objfile
*) NULL
);
10178 builtin_type_ada_char
=
10179 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10180 0, "character", (struct objfile
*) NULL
);
10181 builtin_type_ada_float
=
10182 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
10183 0, "float", (struct objfile
*) NULL
);
10184 builtin_type_ada_double
=
10185 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10186 0, "long_float", (struct objfile
*) NULL
);
10187 builtin_type_ada_long_long
=
10188 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10189 0, "long_long_integer", (struct objfile
*) NULL
);
10190 builtin_type_ada_long_double
=
10191 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10192 0, "long_long_float", (struct objfile
*) NULL
);
10193 builtin_type_ada_natural
=
10194 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10195 0, "natural", (struct objfile
*) NULL
);
10196 builtin_type_ada_positive
=
10197 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10198 0, "positive", (struct objfile
*) NULL
);
10201 builtin_type_ada_system_address
=
10202 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
10203 (struct objfile
*) NULL
));
10204 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
10208 _initialize_ada_language (void)
10211 build_ada_types ();
10212 deprecated_register_gdbarch_swap (NULL
, 0, build_ada_types
);
10213 add_language (&ada_language_defn
);
10215 varsize_limit
= 65536;
10218 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
10219 (char *) &varsize_limit
,
10220 "Set maximum bytes in dynamic-sized object.",
10221 &setlist
), &showlist
);
10222 obstack_init (&cache_space
);
10223 #endif /* GNAT_GDB */
10225 obstack_init (&symbol_list_obstack
);
10227 decoded_names_store
= htab_create_alloc_ex
10228 (256, htab_hash_string
, (int (*)(const void *, const void *)) streq
,
10229 NULL
, NULL
, xmcalloc
, xmfree
);
10232 /* Create a fundamental Ada type using default reasonable for the current
10235 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
10236 define fundamental types such as "int" or "double". Others (stabs or
10237 DWARF version 2, etc) do define fundamental types. For the formats which
10238 don't provide fundamental types, gdb can create such types using this
10241 FIXME: Some compilers distinguish explicitly signed integral types
10242 (signed short, signed int, signed long) from "regular" integral types
10243 (short, int, long) in the debugging information. There is some dis-
10244 agreement as to how useful this feature is. In particular, gcc does
10245 not support this. Also, only some debugging formats allow the
10246 distinction to be passed on to a debugger. For now, we always just
10247 use "short", "int", or "long" as the type name, for both the implicit
10248 and explicitly signed types. This also makes life easier for the
10249 gdb test suite since we don't have to account for the differences
10250 in output depending upon what the compiler and debugging format
10251 support. We will probably have to re-examine the issue when gdb
10252 starts taking it's fundamental type information directly from the
10253 debugging information supplied by the compiler. fnf@cygnus.com */
10255 static struct type
*
10256 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
10258 struct type
*type
= NULL
;
10263 /* FIXME: For now, if we are asked to produce a type not in this
10264 language, create the equivalent of a C integer type with the
10265 name "<?type?>". When all the dust settles from the type
10266 reconstruction work, this should probably become an error. */
10267 type
= init_type (TYPE_CODE_INT
,
10268 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10269 0, "<?type?>", objfile
);
10270 warning ("internal error: no Ada fundamental type %d", typeid);
10273 type
= init_type (TYPE_CODE_VOID
,
10274 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10275 0, "void", objfile
);
10278 type
= init_type (TYPE_CODE_INT
,
10279 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10280 0, "character", objfile
);
10282 case FT_SIGNED_CHAR
:
10283 type
= init_type (TYPE_CODE_INT
,
10284 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10285 0, "signed char", objfile
);
10287 case FT_UNSIGNED_CHAR
:
10288 type
= init_type (TYPE_CODE_INT
,
10289 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
10290 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
10293 type
= init_type (TYPE_CODE_INT
,
10294 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10295 0, "short_integer", objfile
);
10297 case FT_SIGNED_SHORT
:
10298 type
= init_type (TYPE_CODE_INT
,
10299 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10300 0, "short_integer", objfile
);
10302 case FT_UNSIGNED_SHORT
:
10303 type
= init_type (TYPE_CODE_INT
,
10304 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
10305 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
10308 type
= init_type (TYPE_CODE_INT
,
10309 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10310 0, "integer", objfile
);
10312 case FT_SIGNED_INTEGER
:
10313 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
10315 case FT_UNSIGNED_INTEGER
:
10316 type
= init_type (TYPE_CODE_INT
,
10317 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
10318 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
10321 type
= init_type (TYPE_CODE_INT
,
10322 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10323 0, "long_integer", objfile
);
10325 case FT_SIGNED_LONG
:
10326 type
= init_type (TYPE_CODE_INT
,
10327 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10328 0, "long_integer", objfile
);
10330 case FT_UNSIGNED_LONG
:
10331 type
= init_type (TYPE_CODE_INT
,
10332 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
10333 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
10336 type
= init_type (TYPE_CODE_INT
,
10337 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10338 0, "long_long_integer", objfile
);
10340 case FT_SIGNED_LONG_LONG
:
10341 type
= init_type (TYPE_CODE_INT
,
10342 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10343 0, "long_long_integer", objfile
);
10345 case FT_UNSIGNED_LONG_LONG
:
10346 type
= init_type (TYPE_CODE_INT
,
10347 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
10348 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
10351 type
= init_type (TYPE_CODE_FLT
,
10352 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
10353 0, "float", objfile
);
10355 case FT_DBL_PREC_FLOAT
:
10356 type
= init_type (TYPE_CODE_FLT
,
10357 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10358 0, "long_float", objfile
);
10360 case FT_EXT_PREC_FLOAT
:
10361 type
= init_type (TYPE_CODE_FLT
,
10362 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
10363 0, "long_long_float", objfile
);
10370 ada_dump_symtab (struct symtab
*s
)
10373 fprintf (stderr
, "New symtab: [\n");
10374 fprintf (stderr
, " Name: %s/%s;\n",
10375 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
10376 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
10377 if (s
->linetable
!= NULL
)
10379 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
10380 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
10382 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
10383 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
10386 fprintf (stderr
, "]\n");