1 /* Ada language support routines for GDB, the GNU debugger. Copyright
2 1992, 1993, 1994, 1997, 1998, 1999, 2000, 2003
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 #include "gdb_string.h"
30 #include "expression.h"
31 #include "parser-defs.h"
37 #include "breakpoint.h"
44 struct cleanup
*unresolved_names
;
46 void extract_string (CORE_ADDR addr
, char *buf
);
48 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
50 static void modify_general_field (char *, LONGEST
, int, int);
52 static struct type
*desc_base_type (struct type
*);
54 static struct type
*desc_bounds_type (struct type
*);
56 static struct value
*desc_bounds (struct value
*);
58 static int fat_pntr_bounds_bitpos (struct type
*);
60 static int fat_pntr_bounds_bitsize (struct type
*);
62 static struct type
*desc_data_type (struct type
*);
64 static struct value
*desc_data (struct value
*);
66 static int fat_pntr_data_bitpos (struct type
*);
68 static int fat_pntr_data_bitsize (struct type
*);
70 static struct value
*desc_one_bound (struct value
*, int, int);
72 static int desc_bound_bitpos (struct type
*, int, int);
74 static int desc_bound_bitsize (struct type
*, int, int);
76 static struct type
*desc_index_type (struct type
*, int);
78 static int desc_arity (struct type
*);
80 static int ada_type_match (struct type
*, struct type
*, int);
82 static int ada_args_match (struct symbol
*, struct value
**, int);
84 static struct value
*place_on_stack (struct value
*, CORE_ADDR
*);
86 static struct value
*convert_actual (struct value
*, struct type
*,
89 static struct value
*make_array_descriptor (struct type
*, struct value
*,
92 static void ada_add_block_symbols (struct block
*, const char *,
93 domain_enum
, struct objfile
*, int);
95 static void fill_in_ada_prototype (struct symbol
*);
97 static int is_nonfunction (struct symbol
**, int);
99 static void add_defn_to_vec (struct symbol
*, struct block
*);
101 static struct partial_symbol
*ada_lookup_partial_symbol (struct partial_symtab
102 *, const char *, int,
105 static struct symtab
*symtab_for_sym (struct symbol
*);
107 static struct value
*ada_resolve_subexp (struct expression
**, int *, int,
110 static void replace_operator_with_call (struct expression
**, int, int, int,
111 struct symbol
*, struct block
*);
113 static int possible_user_operator_p (enum exp_opcode
, struct value
**);
115 static const char *ada_op_name (enum exp_opcode
);
117 static int numeric_type_p (struct type
*);
119 static int integer_type_p (struct type
*);
121 static int scalar_type_p (struct type
*);
123 static int discrete_type_p (struct type
*);
125 static char *extended_canonical_line_spec (struct symtab_and_line
,
128 static struct value
*evaluate_subexp (struct type
*, struct expression
*,
131 static struct value
*evaluate_subexp_type (struct expression
*, int *);
133 static struct type
*ada_create_fundamental_type (struct objfile
*, int);
135 static int is_dynamic_field (struct type
*, int);
137 static struct type
*to_fixed_variant_branch_type (struct type
*, char *,
138 CORE_ADDR
, struct value
*);
140 static struct type
*to_fixed_range_type (char *, struct value
*,
143 static struct type
*to_static_fixed_type (struct type
*);
145 static struct value
*unwrap_value (struct value
*);
147 static struct type
*packed_array_type (struct type
*, long *);
149 static struct type
*decode_packed_array_type (struct type
*);
151 static struct value
*decode_packed_array (struct value
*);
153 static struct value
*value_subscript_packed (struct value
*, int,
156 static struct value
*coerce_unspec_val_to_type (struct value
*, long,
159 static struct value
*get_var_value (char *, char *);
161 static int lesseq_defined_than (struct symbol
*, struct symbol
*);
163 static int equiv_types (struct type
*, struct type
*);
165 static int is_name_suffix (const char *);
167 static int wild_match (const char *, int, const char *);
169 static struct symtabs_and_lines
find_sal_from_funcs_and_line (const char *,
174 static int find_line_in_linetable (struct linetable
*, int, struct symbol
**,
177 static int find_next_line_in_linetable (struct linetable
*, int, int, int);
179 static struct symtabs_and_lines
all_sals_for_line (const char *, int,
182 static void read_all_symtabs (const char *);
184 static int is_plausible_func_for_line (struct symbol
*, int);
186 static struct value
*ada_coerce_ref (struct value
*);
188 static struct value
*value_pos_atr (struct value
*);
190 static struct value
*value_val_atr (struct type
*, struct value
*);
192 static struct symbol
*standard_lookup (const char *, domain_enum
);
194 extern void markTimeStart (int index
);
195 extern void markTimeStop (int index
);
199 /* Maximum-sized dynamic type. */
200 static unsigned int varsize_limit
;
202 static const char *ada_completer_word_break_characters
=
203 " \t\n!@#$%^&*()+=|~`}{[]\";:?/,-";
205 /* The name of the symbol to use to get the name of the main subprogram */
206 #define ADA_MAIN_PROGRAM_SYMBOL_NAME "__gnat_ada_main_program_name"
212 * read the string located at ADDR from the inferior and store the
216 extract_string (CORE_ADDR addr
, char *buf
)
220 /* Loop, reading one byte at a time, until we reach the '\000'
221 end-of-string marker */
224 target_read_memory (addr
+ char_index
* sizeof (char),
225 buf
+ char_index
* sizeof (char), sizeof (char));
228 while (buf
[char_index
- 1] != '\000');
231 /* Assuming *OLD_VECT points to an array of *SIZE objects of size
232 ELEMENT_SIZE, grow it to contain at least MIN_SIZE objects,
233 updating *OLD_VECT and *SIZE as necessary. */
236 grow_vect (void **old_vect
, size_t * size
, size_t min_size
, int element_size
)
238 if (*size
< min_size
)
241 if (*size
< min_size
)
243 *old_vect
= xrealloc (*old_vect
, *size
* element_size
);
247 /* True (non-zero) iff TARGET matches FIELD_NAME up to any trailing
248 suffix of FIELD_NAME beginning "___" */
251 field_name_match (const char *field_name
, const char *target
)
253 int len
= strlen (target
);
255 STREQN (field_name
, target
, len
)
256 && (field_name
[len
] == '\0'
257 || (STREQN (field_name
+ len
, "___", 3)
258 && !STREQ (field_name
+ strlen (field_name
) - 6, "___XVN")));
262 /* The length of the prefix of NAME prior to any "___" suffix. */
265 ada_name_prefix_len (const char *name
)
271 const char *p
= strstr (name
, "___");
273 return strlen (name
);
279 /* SUFFIX is a suffix of STR. False if STR is null. */
281 is_suffix (const char *str
, const char *suffix
)
287 len2
= strlen (suffix
);
288 return (len1
>= len2
&& STREQ (str
+ len1
- len2
, suffix
));
291 /* Create a value of type TYPE whose contents come from VALADDR, if it
292 * is non-null, and whose memory address (in the inferior) is
295 value_from_contents_and_address (struct type
*type
, char *valaddr
,
298 struct value
*v
= allocate_value (type
);
302 memcpy (VALUE_CONTENTS_RAW (v
), valaddr
, TYPE_LENGTH (type
));
303 VALUE_ADDRESS (v
) = address
;
305 VALUE_LVAL (v
) = lval_memory
;
309 /* The contents of value VAL, beginning at offset OFFSET, treated as a
310 value of type TYPE. The result is an lval in memory if VAL is. */
312 static struct value
*
313 coerce_unspec_val_to_type (struct value
*val
, long offset
, struct type
*type
)
315 CHECK_TYPEDEF (type
);
316 if (VALUE_LVAL (val
) == lval_memory
)
317 return value_at_lazy (type
,
318 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
,
322 struct value
*result
= allocate_value (type
);
323 VALUE_LVAL (result
) = not_lval
;
324 if (VALUE_ADDRESS (val
) == 0)
325 memcpy (VALUE_CONTENTS_RAW (result
), VALUE_CONTENTS (val
) + offset
,
326 TYPE_LENGTH (type
) > TYPE_LENGTH (VALUE_TYPE (val
))
327 ? TYPE_LENGTH (VALUE_TYPE (val
)) : TYPE_LENGTH (type
));
330 VALUE_ADDRESS (result
) =
331 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
) + offset
;
332 VALUE_LAZY (result
) = 1;
339 cond_offset_host (char *valaddr
, long offset
)
344 return valaddr
+ offset
;
348 cond_offset_target (CORE_ADDR address
, long offset
)
353 return address
+ offset
;
356 /* Perform execute_command on the result of concatenating all
357 arguments up to NULL. */
359 do_command (const char *arg
, ...)
370 for (; s
!= NULL
; s
= va_arg (ap
, const char *))
374 cmd1
= alloca (len
+ 1);
380 execute_command (cmd
, 0);
384 /* Language Selection */
386 /* If the main program is in Ada, return language_ada, otherwise return LANG
387 (the main program is in Ada iif the adainit symbol is found).
389 MAIN_PST is not used. */
392 ada_update_initial_language (enum language lang
,
393 struct partial_symtab
*main_pst
)
395 if (lookup_minimal_symbol ("adainit", (const char *) NULL
,
396 (struct objfile
*) NULL
) != NULL
)
397 /* return language_ada; */
398 /* FIXME: language_ada should be defined in defs.h */
399 return language_unknown
;
407 /* Table of Ada operators and their GNAT-mangled names. Last entry is pair
410 const struct ada_opname_map ada_opname_table
[] = {
411 {"Oadd", "\"+\"", BINOP_ADD
},
412 {"Osubtract", "\"-\"", BINOP_SUB
},
413 {"Omultiply", "\"*\"", BINOP_MUL
},
414 {"Odivide", "\"/\"", BINOP_DIV
},
415 {"Omod", "\"mod\"", BINOP_MOD
},
416 {"Orem", "\"rem\"", BINOP_REM
},
417 {"Oexpon", "\"**\"", BINOP_EXP
},
418 {"Olt", "\"<\"", BINOP_LESS
},
419 {"Ole", "\"<=\"", BINOP_LEQ
},
420 {"Ogt", "\">\"", BINOP_GTR
},
421 {"Oge", "\">=\"", BINOP_GEQ
},
422 {"Oeq", "\"=\"", BINOP_EQUAL
},
423 {"One", "\"/=\"", BINOP_NOTEQUAL
},
424 {"Oand", "\"and\"", BINOP_BITWISE_AND
},
425 {"Oor", "\"or\"", BINOP_BITWISE_IOR
},
426 {"Oxor", "\"xor\"", BINOP_BITWISE_XOR
},
427 {"Oconcat", "\"&\"", BINOP_CONCAT
},
428 {"Oabs", "\"abs\"", UNOP_ABS
},
429 {"Onot", "\"not\"", UNOP_LOGICAL_NOT
},
430 {"Oadd", "\"+\"", UNOP_PLUS
},
431 {"Osubtract", "\"-\"", UNOP_NEG
},
435 /* True if STR should be suppressed in info listings. */
437 is_suppressed_name (const char *str
)
439 if (STREQN (str
, "_ada_", 5))
441 if (str
[0] == '_' || str
[0] == '\000')
446 const char *suffix
= strstr (str
, "___");
447 if (suffix
!= NULL
&& suffix
[3] != 'X')
450 suffix
= str
+ strlen (str
);
451 for (p
= suffix
- 1; p
!= str
; p
-= 1)
455 if (p
[0] == 'X' && p
[-1] != '_')
459 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
460 if (STREQN (ada_opname_table
[i
].mangled
, p
,
461 strlen (ada_opname_table
[i
].mangled
)))
470 /* The "mangled" form of DEMANGLED, according to GNAT conventions.
471 * The result is valid until the next call to ada_mangle. */
473 ada_mangle (const char *demangled
)
475 static char *mangling_buffer
= NULL
;
476 static size_t mangling_buffer_size
= 0;
480 if (demangled
== NULL
)
483 GROW_VECT (mangling_buffer
, mangling_buffer_size
,
484 2 * strlen (demangled
) + 10);
487 for (p
= demangled
; *p
!= '\0'; p
+= 1)
491 mangling_buffer
[k
] = mangling_buffer
[k
+ 1] = '_';
496 const struct ada_opname_map
*mapping
;
498 for (mapping
= ada_opname_table
;
499 mapping
->mangled
!= NULL
&&
500 !STREQN (mapping
->demangled
, p
, strlen (mapping
->demangled
));
503 if (mapping
->mangled
== NULL
)
504 error ("invalid Ada operator name: %s", p
);
505 strcpy (mangling_buffer
+ k
, mapping
->mangled
);
506 k
+= strlen (mapping
->mangled
);
511 mangling_buffer
[k
] = *p
;
516 mangling_buffer
[k
] = '\0';
517 return mangling_buffer
;
520 /* Return NAME folded to lower case, or, if surrounded by single
521 * quotes, unfolded, but with the quotes stripped away. Result good
524 ada_fold_name (const char *name
)
526 static char *fold_buffer
= NULL
;
527 static size_t fold_buffer_size
= 0;
529 int len
= strlen (name
);
530 GROW_VECT (fold_buffer
, fold_buffer_size
, len
+ 1);
534 strncpy (fold_buffer
, name
+ 1, len
- 2);
535 fold_buffer
[len
- 2] = '\000';
540 for (i
= 0; i
<= len
; i
+= 1)
541 fold_buffer
[i
] = tolower (name
[i
]);
548 1. Discard final __{DIGIT}+ or ${DIGIT}+
549 2. Convert other instances of embedded "__" to `.'.
550 3. Discard leading _ada_.
551 4. Convert operator names to the appropriate quoted symbols.
552 5. Remove everything after first ___ if it is followed by
554 6. Replace TK__ with __, and a trailing B or TKB with nothing.
555 7. Put symbols that should be suppressed in <...> brackets.
556 8. Remove trailing X[bn]* suffix (indicating names in package bodies).
557 The resulting string is valid until the next call of ada_demangle.
561 ada_demangle (const char *mangled
)
568 static char *demangling_buffer
= NULL
;
569 static size_t demangling_buffer_size
= 0;
571 if (STREQN (mangled
, "_ada_", 5))
574 if (mangled
[0] == '_' || mangled
[0] == '<')
577 p
= strstr (mangled
, "___");
579 len0
= strlen (mangled
);
587 if (len0
> 3 && STREQ (mangled
+ len0
- 3, "TKB"))
589 if (len0
> 1 && STREQ (mangled
+ len0
- 1, "B"))
592 /* Make demangled big enough for possible expansion by operator name. */
593 GROW_VECT (demangling_buffer
, demangling_buffer_size
, 2 * len0
+ 1);
594 demangled
= demangling_buffer
;
596 if (isdigit (mangled
[len0
- 1]))
598 for (i
= len0
- 2; i
>= 0 && isdigit (mangled
[i
]); i
-= 1)
600 if (i
> 1 && mangled
[i
] == '_' && mangled
[i
- 1] == '_')
602 else if (mangled
[i
] == '$')
606 for (i
= 0, j
= 0; i
< len0
&& !isalpha (mangled
[i
]); i
+= 1, j
+= 1)
607 demangled
[j
] = mangled
[i
];
612 if (at_start_name
&& mangled
[i
] == 'O')
615 for (k
= 0; ada_opname_table
[k
].mangled
!= NULL
; k
+= 1)
617 int op_len
= strlen (ada_opname_table
[k
].mangled
);
619 (ada_opname_table
[k
].mangled
+ 1, mangled
+ i
+ 1,
620 op_len
- 1) && !isalnum (mangled
[i
+ op_len
]))
622 strcpy (demangled
+ j
, ada_opname_table
[k
].demangled
);
625 j
+= strlen (ada_opname_table
[k
].demangled
);
629 if (ada_opname_table
[k
].mangled
!= NULL
)
634 if (i
< len0
- 4 && STREQN (mangled
+ i
, "TK__", 4))
636 if (mangled
[i
] == 'X' && i
!= 0 && isalnum (mangled
[i
- 1]))
640 while (i
< len0
&& (mangled
[i
] == 'b' || mangled
[i
] == 'n'));
644 else if (i
< len0
- 2 && mangled
[i
] == '_' && mangled
[i
+ 1] == '_')
653 demangled
[j
] = mangled
[i
];
658 demangled
[j
] = '\000';
660 for (i
= 0; demangled
[i
] != '\0'; i
+= 1)
661 if (isupper (demangled
[i
]) || demangled
[i
] == ' ')
667 GROW_VECT (demangling_buffer
, demangling_buffer_size
, strlen (mangled
) + 3);
668 demangled
= demangling_buffer
;
669 if (mangled
[0] == '<')
670 strcpy (demangled
, mangled
);
672 sprintf (demangled
, "<%s>", mangled
);
677 /* Returns non-zero iff SYM_NAME matches NAME, ignoring any trailing
678 * suffixes that encode debugging information or leading _ada_ on
679 * SYM_NAME (see is_name_suffix commentary for the debugging
680 * information that is ignored). If WILD, then NAME need only match a
681 * suffix of SYM_NAME minus the same suffixes. Also returns 0 if
682 * either argument is NULL. */
685 ada_match_name (const char *sym_name
, const char *name
, int wild
)
687 if (sym_name
== NULL
|| name
== NULL
)
690 return wild_match (name
, strlen (name
), sym_name
);
693 int len_name
= strlen (name
);
694 return (STREQN (sym_name
, name
, len_name
)
695 && is_name_suffix (sym_name
+ len_name
))
696 || (STREQN (sym_name
, "_ada_", 5)
697 && STREQN (sym_name
+ 5, name
, len_name
)
698 && is_name_suffix (sym_name
+ len_name
+ 5));
702 /* True (non-zero) iff in Ada mode, the symbol SYM should be
703 suppressed in info listings. */
706 ada_suppress_symbol_printing (struct symbol
*sym
)
708 if (SYMBOL_DOMAIN (sym
) == STRUCT_DOMAIN
)
711 return is_suppressed_name (DEPRECATED_SYMBOL_NAME (sym
));
717 /* Names of MAX_ADA_DIMENS bounds in P_BOUNDS fields of
718 array descriptors. */
720 static char *bound_name
[] = {
721 "LB0", "UB0", "LB1", "UB1", "LB2", "UB2", "LB3", "UB3",
722 "LB4", "UB4", "LB5", "UB5", "LB6", "UB6", "LB7", "UB7"
725 /* Maximum number of array dimensions we are prepared to handle. */
727 #define MAX_ADA_DIMENS (sizeof(bound_name) / (2*sizeof(char*)))
729 /* Like modify_field, but allows bitpos > wordlength. */
732 modify_general_field (char *addr
, LONGEST fieldval
, int bitpos
, int bitsize
)
734 modify_field (addr
+ sizeof (LONGEST
) * bitpos
/ (8 * sizeof (LONGEST
)),
735 fieldval
, bitpos
% (8 * sizeof (LONGEST
)), bitsize
);
739 /* The desc_* routines return primitive portions of array descriptors
742 /* The descriptor or array type, if any, indicated by TYPE; removes
743 level of indirection, if needed. */
745 desc_base_type (struct type
*type
)
749 CHECK_TYPEDEF (type
);
750 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_PTR
)
751 return check_typedef (TYPE_TARGET_TYPE (type
));
756 /* True iff TYPE indicates a "thin" array pointer type. */
758 is_thin_pntr (struct type
*type
)
761 is_suffix (ada_type_name (desc_base_type (type
)), "___XUT")
762 || is_suffix (ada_type_name (desc_base_type (type
)), "___XUT___XVE");
765 /* The descriptor type for thin pointer type TYPE. */
767 thin_descriptor_type (struct type
*type
)
769 struct type
*base_type
= desc_base_type (type
);
770 if (base_type
== NULL
)
772 if (is_suffix (ada_type_name (base_type
), "___XVE"))
776 struct type
*alt_type
= ada_find_parallel_type (base_type
, "___XVE");
777 if (alt_type
== NULL
)
784 /* A pointer to the array data for thin-pointer value VAL. */
785 static struct value
*
786 thin_data_pntr (struct value
*val
)
788 struct type
*type
= VALUE_TYPE (val
);
789 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
790 return value_cast (desc_data_type (thin_descriptor_type (type
)),
793 return value_from_longest (desc_data_type (thin_descriptor_type (type
)),
794 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
));
797 /* True iff TYPE indicates a "thick" array pointer type. */
799 is_thick_pntr (struct type
*type
)
801 type
= desc_base_type (type
);
802 return (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_STRUCT
803 && lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
);
806 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
807 pointer to one, the type of its bounds data; otherwise, NULL. */
809 desc_bounds_type (struct type
*type
)
813 type
= desc_base_type (type
);
817 else if (is_thin_pntr (type
))
819 type
= thin_descriptor_type (type
);
822 r
= lookup_struct_elt_type (type
, "BOUNDS", 1);
824 return check_typedef (r
);
826 else if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
828 r
= lookup_struct_elt_type (type
, "P_BOUNDS", 1);
830 return check_typedef (TYPE_TARGET_TYPE (check_typedef (r
)));
835 /* If ARR is an array descriptor (fat or thin pointer), or pointer to
836 one, a pointer to its bounds data. Otherwise NULL. */
837 static struct value
*
838 desc_bounds (struct value
*arr
)
840 struct type
*type
= check_typedef (VALUE_TYPE (arr
));
841 if (is_thin_pntr (type
))
843 struct type
*bounds_type
=
844 desc_bounds_type (thin_descriptor_type (type
));
847 if (desc_bounds_type
== NULL
)
848 error ("Bad GNAT array descriptor");
850 /* NOTE: The following calculation is not really kosher, but
851 since desc_type is an XVE-encoded type (and shouldn't be),
852 the correct calculation is a real pain. FIXME (and fix GCC). */
853 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
854 addr
= value_as_long (arr
);
856 addr
= VALUE_ADDRESS (arr
) + VALUE_OFFSET (arr
);
859 value_from_longest (lookup_pointer_type (bounds_type
),
860 addr
- TYPE_LENGTH (bounds_type
));
863 else if (is_thick_pntr (type
))
864 return value_struct_elt (&arr
, NULL
, "P_BOUNDS", NULL
,
865 "Bad GNAT array descriptor");
870 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
871 position of the field containing the address of the bounds data. */
873 fat_pntr_bounds_bitpos (struct type
*type
)
875 return TYPE_FIELD_BITPOS (desc_base_type (type
), 1);
878 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
879 size of the field containing the address of the bounds data. */
881 fat_pntr_bounds_bitsize (struct type
*type
)
883 type
= desc_base_type (type
);
885 if (TYPE_FIELD_BITSIZE (type
, 1) > 0)
886 return TYPE_FIELD_BITSIZE (type
, 1);
888 return 8 * TYPE_LENGTH (check_typedef (TYPE_FIELD_TYPE (type
, 1)));
891 /* If TYPE is the type of an array descriptor (fat or thin pointer) or a
892 pointer to one, the type of its array data (a
893 pointer-to-array-with-no-bounds type); otherwise, NULL. Use
894 ada_type_of_array to get an array type with bounds data. */
896 desc_data_type (struct type
*type
)
898 type
= desc_base_type (type
);
900 /* NOTE: The following is bogus; see comment in desc_bounds. */
901 if (is_thin_pntr (type
))
902 return lookup_pointer_type
903 (desc_base_type (TYPE_FIELD_TYPE (thin_descriptor_type (type
), 1)));
904 else if (is_thick_pntr (type
))
905 return lookup_struct_elt_type (type
, "P_ARRAY", 1);
910 /* If ARR is an array descriptor (fat or thin pointer), a pointer to
912 static struct value
*
913 desc_data (struct value
*arr
)
915 struct type
*type
= VALUE_TYPE (arr
);
916 if (is_thin_pntr (type
))
917 return thin_data_pntr (arr
);
918 else if (is_thick_pntr (type
))
919 return value_struct_elt (&arr
, NULL
, "P_ARRAY", NULL
,
920 "Bad GNAT array descriptor");
926 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
927 position of the field containing the address of the data. */
929 fat_pntr_data_bitpos (struct type
*type
)
931 return TYPE_FIELD_BITPOS (desc_base_type (type
), 0);
934 /* If TYPE is the type of an array-descriptor (fat pointer), the bit
935 size of the field containing the address of the data. */
937 fat_pntr_data_bitsize (struct type
*type
)
939 type
= desc_base_type (type
);
941 if (TYPE_FIELD_BITSIZE (type
, 0) > 0)
942 return TYPE_FIELD_BITSIZE (type
, 0);
944 return TARGET_CHAR_BIT
* TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 0));
947 /* If BOUNDS is an array-bounds structure (or pointer to one), return
948 the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
949 bound, if WHICH is 1. The first bound is I=1. */
950 static struct value
*
951 desc_one_bound (struct value
*bounds
, int i
, int which
)
953 return value_struct_elt (&bounds
, NULL
, bound_name
[2 * i
+ which
- 2], NULL
,
954 "Bad GNAT array descriptor bounds");
957 /* If BOUNDS is an array-bounds structure type, return the bit position
958 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
959 bound, if WHICH is 1. The first bound is I=1. */
961 desc_bound_bitpos (struct type
*type
, int i
, int which
)
963 return TYPE_FIELD_BITPOS (desc_base_type (type
), 2 * i
+ which
- 2);
966 /* If BOUNDS is an array-bounds structure type, return the bit field size
967 of the Ith lower bound stored in it, if WHICH is 0, and the Ith upper
968 bound, if WHICH is 1. The first bound is I=1. */
970 desc_bound_bitsize (struct type
*type
, int i
, int which
)
972 type
= desc_base_type (type
);
974 if (TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2) > 0)
975 return TYPE_FIELD_BITSIZE (type
, 2 * i
+ which
- 2);
977 return 8 * TYPE_LENGTH (TYPE_FIELD_TYPE (type
, 2 * i
+ which
- 2));
980 /* If TYPE is the type of an array-bounds structure, the type of its
981 Ith bound (numbering from 1). Otherwise, NULL. */
983 desc_index_type (struct type
*type
, int i
)
985 type
= desc_base_type (type
);
987 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
988 return lookup_struct_elt_type (type
, bound_name
[2 * i
- 2], 1);
993 /* The number of index positions in the array-bounds type TYPE. 0
996 desc_arity (struct type
*type
)
998 type
= desc_base_type (type
);
1001 return TYPE_NFIELDS (type
) / 2;
1006 /* Non-zero iff type is a simple array type (or pointer to one). */
1008 ada_is_simple_array (struct type
*type
)
1012 CHECK_TYPEDEF (type
);
1013 return (TYPE_CODE (type
) == TYPE_CODE_ARRAY
1014 || (TYPE_CODE (type
) == TYPE_CODE_PTR
1015 && TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
));
1018 /* Non-zero iff type belongs to a GNAT array descriptor. */
1020 ada_is_array_descriptor (struct type
*type
)
1022 struct type
*data_type
= desc_data_type (type
);
1026 CHECK_TYPEDEF (type
);
1029 && ((TYPE_CODE (data_type
) == TYPE_CODE_PTR
1030 && TYPE_TARGET_TYPE (data_type
) != NULL
1031 && TYPE_CODE (TYPE_TARGET_TYPE (data_type
)) == TYPE_CODE_ARRAY
)
1033 TYPE_CODE (data_type
) == TYPE_CODE_ARRAY
)
1034 && desc_arity (desc_bounds_type (type
)) > 0;
1037 /* Non-zero iff type is a partially mal-formed GNAT array
1038 descriptor. (FIXME: This is to compensate for some problems with
1039 debugging output from GNAT. Re-examine periodically to see if it
1042 ada_is_bogus_array_descriptor (struct type
*type
)
1046 && TYPE_CODE (type
) == TYPE_CODE_STRUCT
1047 && (lookup_struct_elt_type (type
, "P_BOUNDS", 1) != NULL
1048 || lookup_struct_elt_type (type
, "P_ARRAY", 1) != NULL
)
1049 && !ada_is_array_descriptor (type
);
1053 /* If ARR has a record type in the form of a standard GNAT array descriptor,
1054 (fat pointer) returns the type of the array data described---specifically,
1055 a pointer-to-array type. If BOUNDS is non-zero, the bounds data are filled
1056 in from the descriptor; otherwise, they are left unspecified. If
1057 the ARR denotes a null array descriptor and BOUNDS is non-zero,
1058 returns NULL. The result is simply the type of ARR if ARR is not
1061 ada_type_of_array (struct value
*arr
, int bounds
)
1063 if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1064 return decode_packed_array_type (VALUE_TYPE (arr
));
1066 if (!ada_is_array_descriptor (VALUE_TYPE (arr
)))
1067 return VALUE_TYPE (arr
);
1071 check_typedef (TYPE_TARGET_TYPE (desc_data_type (VALUE_TYPE (arr
))));
1074 struct type
*elt_type
;
1076 struct value
*descriptor
;
1077 struct objfile
*objf
= TYPE_OBJFILE (VALUE_TYPE (arr
));
1079 elt_type
= ada_array_element_type (VALUE_TYPE (arr
), -1);
1080 arity
= ada_array_arity (VALUE_TYPE (arr
));
1082 if (elt_type
== NULL
|| arity
== 0)
1083 return check_typedef (VALUE_TYPE (arr
));
1085 descriptor
= desc_bounds (arr
);
1086 if (value_as_long (descriptor
) == 0)
1090 struct type
*range_type
= alloc_type (objf
);
1091 struct type
*array_type
= alloc_type (objf
);
1092 struct value
*low
= desc_one_bound (descriptor
, arity
, 0);
1093 struct value
*high
= desc_one_bound (descriptor
, arity
, 1);
1096 create_range_type (range_type
, VALUE_TYPE (low
),
1097 (int) value_as_long (low
),
1098 (int) value_as_long (high
));
1099 elt_type
= create_array_type (array_type
, elt_type
, range_type
);
1102 return lookup_pointer_type (elt_type
);
1106 /* If ARR does not represent an array, returns ARR unchanged.
1107 Otherwise, returns either a standard GDB array with bounds set
1108 appropriately or, if ARR is a non-null fat pointer, a pointer to a standard
1109 GDB array. Returns NULL if ARR is a null fat pointer. */
1111 ada_coerce_to_simple_array_ptr (struct value
*arr
)
1113 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1115 struct type
*arrType
= ada_type_of_array (arr
, 1);
1116 if (arrType
== NULL
)
1118 return value_cast (arrType
, value_copy (desc_data (arr
)));
1120 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1121 return decode_packed_array (arr
);
1126 /* If ARR does not represent an array, returns ARR unchanged.
1127 Otherwise, returns a standard GDB array describing ARR (which may
1128 be ARR itself if it already is in the proper form). */
1130 ada_coerce_to_simple_array (struct value
*arr
)
1132 if (ada_is_array_descriptor (VALUE_TYPE (arr
)))
1134 struct value
*arrVal
= ada_coerce_to_simple_array_ptr (arr
);
1136 error ("Bounds unavailable for null array pointer.");
1137 return value_ind (arrVal
);
1139 else if (ada_is_packed_array_type (VALUE_TYPE (arr
)))
1140 return decode_packed_array (arr
);
1145 /* If TYPE represents a GNAT array type, return it translated to an
1146 ordinary GDB array type (possibly with BITSIZE fields indicating
1147 packing). For other types, is the identity. */
1149 ada_coerce_to_simple_array_type (struct type
*type
)
1151 struct value
*mark
= value_mark ();
1152 struct value
*dummy
= value_from_longest (builtin_type_long
, 0);
1153 struct type
*result
;
1154 VALUE_TYPE (dummy
) = type
;
1155 result
= ada_type_of_array (dummy
, 0);
1156 value_free_to_mark (dummy
);
1160 /* Non-zero iff TYPE represents a standard GNAT packed-array type. */
1162 ada_is_packed_array_type (struct type
*type
)
1166 CHECK_TYPEDEF (type
);
1168 ada_type_name (type
) != NULL
1169 && strstr (ada_type_name (type
), "___XP") != NULL
;
1172 /* Given that TYPE is a standard GDB array type with all bounds filled
1173 in, and that the element size of its ultimate scalar constituents
1174 (that is, either its elements, or, if it is an array of arrays, its
1175 elements' elements, etc.) is *ELT_BITS, return an identical type,
1176 but with the bit sizes of its elements (and those of any
1177 constituent arrays) recorded in the BITSIZE components of its
1178 TYPE_FIELD_BITSIZE values, and with *ELT_BITS set to its total size
1180 static struct type
*
1181 packed_array_type (struct type
*type
, long *elt_bits
)
1183 struct type
*new_elt_type
;
1184 struct type
*new_type
;
1185 LONGEST low_bound
, high_bound
;
1187 CHECK_TYPEDEF (type
);
1188 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1191 new_type
= alloc_type (TYPE_OBJFILE (type
));
1192 new_elt_type
= packed_array_type (check_typedef (TYPE_TARGET_TYPE (type
)),
1194 create_array_type (new_type
, new_elt_type
, TYPE_FIELD_TYPE (type
, 0));
1195 TYPE_FIELD_BITSIZE (new_type
, 0) = *elt_bits
;
1196 TYPE_NAME (new_type
) = ada_type_name (type
);
1198 if (get_discrete_bounds (TYPE_FIELD_TYPE (type
, 0),
1199 &low_bound
, &high_bound
) < 0)
1200 low_bound
= high_bound
= 0;
1201 if (high_bound
< low_bound
)
1202 *elt_bits
= TYPE_LENGTH (new_type
) = 0;
1205 *elt_bits
*= (high_bound
- low_bound
+ 1);
1206 TYPE_LENGTH (new_type
) =
1207 (*elt_bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1210 /* TYPE_FLAGS (new_type) |= TYPE_FLAG_FIXED_INSTANCE; */
1211 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
1215 /* The array type encoded by TYPE, where ada_is_packed_array_type (TYPE).
1217 static struct type
*
1218 decode_packed_array_type (struct type
*type
)
1220 struct symbol
**syms
;
1221 struct block
**blocks
;
1222 const char *raw_name
= ada_type_name (check_typedef (type
));
1223 char *name
= (char *) alloca (strlen (raw_name
) + 1);
1224 char *tail
= strstr (raw_name
, "___XP");
1225 struct type
*shadow_type
;
1229 memcpy (name
, raw_name
, tail
- raw_name
);
1230 name
[tail
- raw_name
] = '\000';
1232 /* NOTE: Use ada_lookup_symbol_list because of bug in some versions
1233 * of gcc (Solaris, e.g.). FIXME when compiler is fixed. */
1234 n
= ada_lookup_symbol_list (name
, get_selected_block (NULL
),
1235 VAR_DOMAIN
, &syms
, &blocks
);
1236 for (i
= 0; i
< n
; i
+= 1)
1237 if (syms
[i
] != NULL
&& SYMBOL_CLASS (syms
[i
]) == LOC_TYPEDEF
1238 && STREQ (name
, ada_type_name (SYMBOL_TYPE (syms
[i
]))))
1242 warning ("could not find bounds information on packed array");
1245 shadow_type
= SYMBOL_TYPE (syms
[i
]);
1247 if (TYPE_CODE (shadow_type
) != TYPE_CODE_ARRAY
)
1249 warning ("could not understand bounds information on packed array");
1253 if (sscanf (tail
+ sizeof ("___XP") - 1, "%ld", &bits
) != 1)
1255 warning ("could not understand bit size information on packed array");
1259 return packed_array_type (shadow_type
, &bits
);
1262 /* Given that ARR is a struct value* indicating a GNAT packed array,
1263 returns a simple array that denotes that array. Its type is a
1264 standard GDB array type except that the BITSIZEs of the array
1265 target types are set to the number of bits in each element, and the
1266 type length is set appropriately. */
1268 static struct value
*
1269 decode_packed_array (struct value
*arr
)
1271 struct type
*type
= decode_packed_array_type (VALUE_TYPE (arr
));
1275 error ("can't unpack array");
1279 return coerce_unspec_val_to_type (arr
, 0, type
);
1283 /* The value of the element of packed array ARR at the ARITY indices
1284 given in IND. ARR must be a simple array. */
1286 static struct value
*
1287 value_subscript_packed (struct value
*arr
, int arity
, struct value
**ind
)
1290 int bits
, elt_off
, bit_off
;
1291 long elt_total_bit_offset
;
1292 struct type
*elt_type
;
1296 elt_total_bit_offset
= 0;
1297 elt_type
= check_typedef (VALUE_TYPE (arr
));
1298 for (i
= 0; i
< arity
; i
+= 1)
1300 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
1301 || TYPE_FIELD_BITSIZE (elt_type
, 0) == 0)
1303 ("attempt to do packed indexing of something other than a packed array");
1306 struct type
*range_type
= TYPE_INDEX_TYPE (elt_type
);
1307 LONGEST lowerbound
, upperbound
;
1310 if (get_discrete_bounds (range_type
, &lowerbound
, &upperbound
) < 0)
1312 warning ("don't know bounds of array");
1313 lowerbound
= upperbound
= 0;
1316 idx
= value_as_long (value_pos_atr (ind
[i
]));
1317 if (idx
< lowerbound
|| idx
> upperbound
)
1318 warning ("packed array index %ld out of bounds", (long) idx
);
1319 bits
= TYPE_FIELD_BITSIZE (elt_type
, 0);
1320 elt_total_bit_offset
+= (idx
- lowerbound
) * bits
;
1321 elt_type
= check_typedef (TYPE_TARGET_TYPE (elt_type
));
1324 elt_off
= elt_total_bit_offset
/ HOST_CHAR_BIT
;
1325 bit_off
= elt_total_bit_offset
% HOST_CHAR_BIT
;
1327 v
= ada_value_primitive_packed_val (arr
, NULL
, elt_off
, bit_off
,
1329 if (VALUE_LVAL (arr
) == lval_internalvar
)
1330 VALUE_LVAL (v
) = lval_internalvar_component
;
1332 VALUE_LVAL (v
) = VALUE_LVAL (arr
);
1336 /* Non-zero iff TYPE includes negative integer values. */
1339 has_negatives (struct type
*type
)
1341 switch (TYPE_CODE (type
))
1346 return !TYPE_UNSIGNED (type
);
1347 case TYPE_CODE_RANGE
:
1348 return TYPE_LOW_BOUND (type
) < 0;
1353 /* Create a new value of type TYPE from the contents of OBJ starting
1354 at byte OFFSET, and bit offset BIT_OFFSET within that byte,
1355 proceeding for BIT_SIZE bits. If OBJ is an lval in memory, then
1356 assigning through the result will set the field fetched from. OBJ
1357 may also be NULL, in which case, VALADDR+OFFSET must address the
1358 start of storage containing the packed value. The value returned
1359 in this case is never an lval.
1360 Assumes 0 <= BIT_OFFSET < HOST_CHAR_BIT. */
1363 ada_value_primitive_packed_val (struct value
*obj
, char *valaddr
, long offset
,
1364 int bit_offset
, int bit_size
,
1368 int src
, /* Index into the source area. */
1369 targ
, /* Index into the target area. */
1370 i
, srcBitsLeft
, /* Number of source bits left to move. */
1371 nsrc
, ntarg
, /* Number of source and target bytes. */
1372 unusedLS
, /* Number of bits in next significant
1373 * byte of source that are unused. */
1374 accumSize
; /* Number of meaningful bits in accum */
1375 unsigned char *bytes
; /* First byte containing data to unpack. */
1376 unsigned char *unpacked
;
1377 unsigned long accum
; /* Staging area for bits being transferred */
1379 int len
= (bit_size
+ bit_offset
+ HOST_CHAR_BIT
- 1) / 8;
1380 /* Transmit bytes from least to most significant; delta is the
1381 * direction the indices move. */
1382 int delta
= BITS_BIG_ENDIAN
? -1 : 1;
1384 CHECK_TYPEDEF (type
);
1388 v
= allocate_value (type
);
1389 bytes
= (unsigned char *) (valaddr
+ offset
);
1391 else if (VALUE_LAZY (obj
))
1394 VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
, NULL
);
1395 bytes
= (unsigned char *) alloca (len
);
1396 read_memory (VALUE_ADDRESS (v
), bytes
, len
);
1400 v
= allocate_value (type
);
1401 bytes
= (unsigned char *) VALUE_CONTENTS (obj
) + offset
;
1406 VALUE_LVAL (v
) = VALUE_LVAL (obj
);
1407 if (VALUE_LVAL (obj
) == lval_internalvar
)
1408 VALUE_LVAL (v
) = lval_internalvar_component
;
1409 VALUE_ADDRESS (v
) = VALUE_ADDRESS (obj
) + VALUE_OFFSET (obj
) + offset
;
1410 VALUE_BITPOS (v
) = bit_offset
+ VALUE_BITPOS (obj
);
1411 VALUE_BITSIZE (v
) = bit_size
;
1412 if (VALUE_BITPOS (v
) >= HOST_CHAR_BIT
)
1414 VALUE_ADDRESS (v
) += 1;
1415 VALUE_BITPOS (v
) -= HOST_CHAR_BIT
;
1419 VALUE_BITSIZE (v
) = bit_size
;
1420 unpacked
= (unsigned char *) VALUE_CONTENTS (v
);
1422 srcBitsLeft
= bit_size
;
1424 ntarg
= TYPE_LENGTH (type
);
1428 memset (unpacked
, 0, TYPE_LENGTH (type
));
1431 else if (BITS_BIG_ENDIAN
)
1434 if (has_negatives (type
) &&
1435 ((bytes
[0] << bit_offset
) & (1 << (HOST_CHAR_BIT
- 1))))
1439 (HOST_CHAR_BIT
- (bit_size
+ bit_offset
) % HOST_CHAR_BIT
)
1442 switch (TYPE_CODE (type
))
1444 case TYPE_CODE_ARRAY
:
1445 case TYPE_CODE_UNION
:
1446 case TYPE_CODE_STRUCT
:
1447 /* Non-scalar values must be aligned at a byte boundary. */
1449 (HOST_CHAR_BIT
- bit_size
% HOST_CHAR_BIT
) % HOST_CHAR_BIT
;
1450 /* And are placed at the beginning (most-significant) bytes
1456 targ
= TYPE_LENGTH (type
) - 1;
1462 int sign_bit_offset
= (bit_size
+ bit_offset
- 1) % 8;
1465 unusedLS
= bit_offset
;
1468 if (has_negatives (type
) && (bytes
[len
- 1] & (1 << sign_bit_offset
)))
1475 /* Mask for removing bits of the next source byte that are not
1476 * part of the value. */
1477 unsigned int unusedMSMask
=
1478 (1 << (srcBitsLeft
>= HOST_CHAR_BIT
? HOST_CHAR_BIT
: srcBitsLeft
)) -
1480 /* Sign-extend bits for this byte. */
1481 unsigned int signMask
= sign
& ~unusedMSMask
;
1483 (((bytes
[src
] >> unusedLS
) & unusedMSMask
) | signMask
) << accumSize
;
1484 accumSize
+= HOST_CHAR_BIT
- unusedLS
;
1485 if (accumSize
>= HOST_CHAR_BIT
)
1487 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1488 accumSize
-= HOST_CHAR_BIT
;
1489 accum
>>= HOST_CHAR_BIT
;
1493 srcBitsLeft
-= HOST_CHAR_BIT
- unusedLS
;
1500 accum
|= sign
<< accumSize
;
1501 unpacked
[targ
] = accum
& ~(~0L << HOST_CHAR_BIT
);
1502 accumSize
-= HOST_CHAR_BIT
;
1503 accum
>>= HOST_CHAR_BIT
;
1511 /* Move N bits from SOURCE, starting at bit offset SRC_OFFSET to
1512 TARGET, starting at bit offset TARG_OFFSET. SOURCE and TARGET must
1515 move_bits (char *target
, int targ_offset
, char *source
, int src_offset
, int n
)
1517 unsigned int accum
, mask
;
1518 int accum_bits
, chunk_size
;
1520 target
+= targ_offset
/ HOST_CHAR_BIT
;
1521 targ_offset
%= HOST_CHAR_BIT
;
1522 source
+= src_offset
/ HOST_CHAR_BIT
;
1523 src_offset
%= HOST_CHAR_BIT
;
1524 if (BITS_BIG_ENDIAN
)
1526 accum
= (unsigned char) *source
;
1528 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1533 accum
= (accum
<< HOST_CHAR_BIT
) + (unsigned char) *source
;
1534 accum_bits
+= HOST_CHAR_BIT
;
1536 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1539 unused_right
= HOST_CHAR_BIT
- (chunk_size
+ targ_offset
);
1540 mask
= ((1 << chunk_size
) - 1) << unused_right
;
1543 | ((accum
>> (accum_bits
- chunk_size
- unused_right
)) & mask
);
1545 accum_bits
-= chunk_size
;
1552 accum
= (unsigned char) *source
>> src_offset
;
1554 accum_bits
= HOST_CHAR_BIT
- src_offset
;
1558 accum
= accum
+ ((unsigned char) *source
<< accum_bits
);
1559 accum_bits
+= HOST_CHAR_BIT
;
1561 chunk_size
= HOST_CHAR_BIT
- targ_offset
;
1564 mask
= ((1 << chunk_size
) - 1) << targ_offset
;
1565 *target
= (*target
& ~mask
) | ((accum
<< targ_offset
) & mask
);
1567 accum_bits
-= chunk_size
;
1568 accum
>>= chunk_size
;
1576 /* Store the contents of FROMVAL into the location of TOVAL.
1577 Return a new value with the location of TOVAL and contents of
1578 FROMVAL. Handles assignment into packed fields that have
1579 floating-point or non-scalar types. */
1581 static struct value
*
1582 ada_value_assign (struct value
*toval
, struct value
*fromval
)
1584 struct type
*type
= VALUE_TYPE (toval
);
1585 int bits
= VALUE_BITSIZE (toval
);
1587 if (!toval
->modifiable
)
1588 error ("Left operand of assignment is not a modifiable lvalue.");
1592 if (VALUE_LVAL (toval
) == lval_memory
1594 && (TYPE_CODE (type
) == TYPE_CODE_FLT
1595 || TYPE_CODE (type
) == TYPE_CODE_STRUCT
))
1598 (VALUE_BITPOS (toval
) + bits
+ HOST_CHAR_BIT
- 1) / HOST_CHAR_BIT
;
1599 char *buffer
= (char *) alloca (len
);
1602 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
1603 fromval
= value_cast (type
, fromval
);
1605 read_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
, len
);
1606 if (BITS_BIG_ENDIAN
)
1607 move_bits (buffer
, VALUE_BITPOS (toval
),
1608 VALUE_CONTENTS (fromval
),
1609 TYPE_LENGTH (VALUE_TYPE (fromval
)) * TARGET_CHAR_BIT
-
1612 move_bits (buffer
, VALUE_BITPOS (toval
), VALUE_CONTENTS (fromval
),
1614 write_memory (VALUE_ADDRESS (toval
) + VALUE_OFFSET (toval
), buffer
,
1617 val
= value_copy (toval
);
1618 memcpy (VALUE_CONTENTS_RAW (val
), VALUE_CONTENTS (fromval
),
1619 TYPE_LENGTH (type
));
1620 VALUE_TYPE (val
) = type
;
1625 return value_assign (toval
, fromval
);
1629 /* The value of the element of array ARR at the ARITY indices given in IND.
1630 ARR may be either a simple array, GNAT array descriptor, or pointer
1634 ada_value_subscript (struct value
*arr
, int arity
, struct value
**ind
)
1638 struct type
*elt_type
;
1640 elt
= ada_coerce_to_simple_array (arr
);
1642 elt_type
= check_typedef (VALUE_TYPE (elt
));
1643 if (TYPE_CODE (elt_type
) == TYPE_CODE_ARRAY
1644 && TYPE_FIELD_BITSIZE (elt_type
, 0) > 0)
1645 return value_subscript_packed (elt
, arity
, ind
);
1647 for (k
= 0; k
< arity
; k
+= 1)
1649 if (TYPE_CODE (elt_type
) != TYPE_CODE_ARRAY
)
1650 error ("too many subscripts (%d expected)", k
);
1651 elt
= value_subscript (elt
, value_pos_atr (ind
[k
]));
1656 /* Assuming ARR is a pointer to a standard GDB array of type TYPE, the
1657 value of the element of *ARR at the ARITY indices given in
1658 IND. Does not read the entire array into memory. */
1661 ada_value_ptr_subscript (struct value
*arr
, struct type
*type
, int arity
,
1666 for (k
= 0; k
< arity
; k
+= 1)
1671 if (TYPE_CODE (type
) != TYPE_CODE_ARRAY
)
1672 error ("too many subscripts (%d expected)", k
);
1673 arr
= value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (type
)),
1675 get_discrete_bounds (TYPE_INDEX_TYPE (type
), &lwb
, &upb
);
1679 idx
= value_sub (ind
[k
], value_from_longest (builtin_type_int
, lwb
));
1680 arr
= value_add (arr
, idx
);
1681 type
= TYPE_TARGET_TYPE (type
);
1684 return value_ind (arr
);
1687 /* If type is a record type in the form of a standard GNAT array
1688 descriptor, returns the number of dimensions for type. If arr is a
1689 simple array, returns the number of "array of"s that prefix its
1690 type designation. Otherwise, returns 0. */
1693 ada_array_arity (struct type
*type
)
1700 type
= desc_base_type (type
);
1703 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1704 return desc_arity (desc_bounds_type (type
));
1706 while (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1709 type
= check_typedef (TYPE_TARGET_TYPE (type
));
1715 /* If TYPE is a record type in the form of a standard GNAT array
1716 descriptor or a simple array type, returns the element type for
1717 TYPE after indexing by NINDICES indices, or by all indices if
1718 NINDICES is -1. Otherwise, returns NULL. */
1721 ada_array_element_type (struct type
*type
, int nindices
)
1723 type
= desc_base_type (type
);
1725 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
1728 struct type
*p_array_type
;
1730 p_array_type
= desc_data_type (type
);
1732 k
= ada_array_arity (type
);
1736 /* Initially p_array_type = elt_type(*)[]...(k times)...[] */
1737 if (nindices
>= 0 && k
> nindices
)
1739 p_array_type
= TYPE_TARGET_TYPE (p_array_type
);
1740 while (k
> 0 && p_array_type
!= NULL
)
1742 p_array_type
= check_typedef (TYPE_TARGET_TYPE (p_array_type
));
1745 return p_array_type
;
1747 else if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1749 while (nindices
!= 0 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
1751 type
= TYPE_TARGET_TYPE (type
);
1760 /* The type of nth index in arrays of given type (n numbering from 1). Does
1761 not examine memory. */
1764 ada_index_type (struct type
*type
, int n
)
1766 type
= desc_base_type (type
);
1768 if (n
> ada_array_arity (type
))
1771 if (ada_is_simple_array (type
))
1775 for (i
= 1; i
< n
; i
+= 1)
1776 type
= TYPE_TARGET_TYPE (type
);
1778 return TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, 0));
1781 return desc_index_type (desc_bounds_type (type
), n
);
1784 /* Given that arr is an array type, returns the lower bound of the
1785 Nth index (numbering from 1) if WHICH is 0, and the upper bound if
1786 WHICH is 1. This returns bounds 0 .. -1 if ARR_TYPE is an
1787 array-descriptor type. If TYPEP is non-null, *TYPEP is set to the
1788 bounds type. It works for other arrays with bounds supplied by
1789 run-time quantities other than discriminants. */
1792 ada_array_bound_from_type (struct type
* arr_type
, int n
, int which
,
1793 struct type
** typep
)
1796 struct type
*index_type_desc
;
1798 if (ada_is_packed_array_type (arr_type
))
1799 arr_type
= decode_packed_array_type (arr_type
);
1801 if (arr_type
== NULL
|| !ada_is_simple_array (arr_type
))
1804 *typep
= builtin_type_int
;
1805 return (LONGEST
) - which
;
1808 if (TYPE_CODE (arr_type
) == TYPE_CODE_PTR
)
1809 type
= TYPE_TARGET_TYPE (arr_type
);
1813 index_type_desc
= ada_find_parallel_type (type
, "___XA");
1814 if (index_type_desc
== NULL
)
1816 struct type
*range_type
;
1817 struct type
*index_type
;
1821 type
= TYPE_TARGET_TYPE (type
);
1825 range_type
= TYPE_INDEX_TYPE (type
);
1826 index_type
= TYPE_TARGET_TYPE (range_type
);
1827 if (TYPE_CODE (index_type
) == TYPE_CODE_UNDEF
)
1828 index_type
= builtin_type_long
;
1830 *typep
= index_type
;
1832 (LONGEST
) (which
== 0
1833 ? TYPE_LOW_BOUND (range_type
)
1834 : TYPE_HIGH_BOUND (range_type
));
1838 struct type
*index_type
=
1839 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, n
- 1),
1840 NULL
, TYPE_OBJFILE (arr_type
));
1842 *typep
= TYPE_TARGET_TYPE (index_type
);
1844 (LONGEST
) (which
== 0
1845 ? TYPE_LOW_BOUND (index_type
)
1846 : TYPE_HIGH_BOUND (index_type
));
1850 /* Given that arr is an array value, returns the lower bound of the
1851 nth index (numbering from 1) if which is 0, and the upper bound if
1852 which is 1. This routine will also work for arrays with bounds
1853 supplied by run-time quantities other than discriminants. */
1856 ada_array_bound (struct value
*arr
, int n
, int which
)
1858 struct type
*arr_type
= VALUE_TYPE (arr
);
1860 if (ada_is_packed_array_type (arr_type
))
1861 return ada_array_bound (decode_packed_array (arr
), n
, which
);
1862 else if (ada_is_simple_array (arr_type
))
1865 LONGEST v
= ada_array_bound_from_type (arr_type
, n
, which
, &type
);
1866 return value_from_longest (type
, v
);
1869 return desc_one_bound (desc_bounds (arr
), n
, which
);
1872 /* Given that arr is an array value, returns the length of the
1873 nth index. This routine will also work for arrays with bounds
1874 supplied by run-time quantities other than discriminants. Does not
1875 work for arrays indexed by enumeration types with representation
1876 clauses at the moment. */
1879 ada_array_length (struct value
*arr
, int n
)
1881 struct type
*arr_type
= check_typedef (VALUE_TYPE (arr
));
1882 struct type
*index_type_desc
;
1884 if (ada_is_packed_array_type (arr_type
))
1885 return ada_array_length (decode_packed_array (arr
), n
);
1887 if (ada_is_simple_array (arr_type
))
1891 ada_array_bound_from_type (arr_type
, n
, 1, &type
) -
1892 ada_array_bound_from_type (arr_type
, n
, 0, NULL
) + 1;
1893 return value_from_longest (type
, v
);
1897 value_from_longest (builtin_type_ada_int
,
1898 value_as_long (desc_one_bound (desc_bounds (arr
),
1900 - value_as_long (desc_one_bound (desc_bounds (arr
),
1905 /* Name resolution */
1907 /* The "demangled" name for the user-definable Ada operator corresponding
1911 ada_op_name (enum exp_opcode op
)
1915 for (i
= 0; ada_opname_table
[i
].mangled
!= NULL
; i
+= 1)
1917 if (ada_opname_table
[i
].op
== op
)
1918 return ada_opname_table
[i
].demangled
;
1920 error ("Could not find operator name for opcode");
1924 /* Same as evaluate_type (*EXP), but resolves ambiguous symbol
1925 references (OP_UNRESOLVED_VALUES) and converts operators that are
1926 user-defined into appropriate function calls. If CONTEXT_TYPE is
1927 non-null, it provides a preferred result type [at the moment, only
1928 type void has any effect---causing procedures to be preferred over
1929 functions in calls]. A null CONTEXT_TYPE indicates that a non-void
1930 return type is preferred. The variable unresolved_names contains a list
1931 of character strings referenced by expout that should be freed.
1932 May change (expand) *EXP. */
1935 ada_resolve (struct expression
**expp
, struct type
*context_type
)
1939 ada_resolve_subexp (expp
, &pc
, 1, context_type
);
1942 /* Resolve the operator of the subexpression beginning at
1943 position *POS of *EXPP. "Resolving" consists of replacing
1944 OP_UNRESOLVED_VALUE with an appropriate OP_VAR_VALUE, replacing
1945 built-in operators with function calls to user-defined operators,
1946 where appropriate, and (when DEPROCEDURE_P is non-zero), converting
1947 function-valued variables into parameterless calls. May expand
1948 EXP. The CONTEXT_TYPE functions as in ada_resolve, above. */
1950 static struct value
*
1951 ada_resolve_subexp (struct expression
**expp
, int *pos
, int deprocedure_p
,
1952 struct type
*context_type
)
1956 struct expression
*exp
; /* Convenience: == *expp */
1957 enum exp_opcode op
= (*expp
)->elts
[pc
].opcode
;
1958 struct value
**argvec
; /* Vector of operand types (alloca'ed). */
1959 int nargs
; /* Number of operands */
1965 /* Pass one: resolve operands, saving their types and updating *pos. */
1969 /* case OP_UNRESOLVED_VALUE: */
1970 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1975 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
) + 1;
1976 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
1977 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
1981 argvec = (struct value* *) alloca (sizeof (struct value*) * (nargs + 1));
1982 for (i = 0; i < nargs-1; i += 1)
1983 argvec[i] = ada_resolve_subexp (expp, pos, 1, NULL);
1989 ada_resolve_subexp (expp, pos, 0, NULL);
1990 for (i = 1; i < nargs; i += 1)
1991 ada_resolve_subexp (expp, pos, 1, NULL);
1997 /* FIXME: UNOP_QUAL should be defined in expression.h */
2001 ada_resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type);
2005 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
2006 /* case OP_ATTRIBUTE:
2007 nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
2009 for (i = 0; i < nargs; i += 1)
2010 ada_resolve_subexp (expp, pos, 1, NULL);
2017 ada_resolve_subexp (expp
, pos
, 0, NULL
);
2026 arg1
= ada_resolve_subexp (expp
, pos
, 0, NULL
);
2028 ada_resolve_subexp (expp
, pos
, 1, NULL
);
2030 ada_resolve_subexp (expp
, pos
, 1, VALUE_TYPE (arg1
));
2038 error ("Unexpected operator during name resolution");
2053 case BINOP_LOGICAL_AND
:
2054 case BINOP_LOGICAL_OR
:
2055 case BINOP_BITWISE_AND
:
2056 case BINOP_BITWISE_IOR
:
2057 case BINOP_BITWISE_XOR
:
2060 case BINOP_NOTEQUAL
:
2067 case BINOP_SUBSCRIPT
:
2075 case UNOP_LOGICAL_NOT
:
2092 case OP_INTERNALVAR
:
2101 case STRUCTOP_STRUCT
:
2104 *pos
+= 4 + BYTES_TO_EXP_ELEM (exp
->elts
[pc
+ 1].longconst
+ 1);
2109 nargs
= longest_to_int (exp
->elts
[pc
+ 2].longconst
) + 1;
2110 nargs
-= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
2111 /* A null array contains one dummy element to give the type. */
2117 /* FIXME: TERNOP_MBR should be defined in expression.h */
2123 /* FIXME: BINOP_MBR should be defined in expression.h */
2131 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
2132 for (i
= 0; i
< nargs
; i
+= 1)
2133 argvec
[i
] = ada_resolve_subexp (expp
, pos
, 1, NULL
);
2139 /* Pass two: perform any resolution on principal operator. */
2145 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2146 /* case OP_UNRESOLVED_VALUE:
2148 struct symbol** candidate_syms;
2149 struct block** candidate_blocks;
2152 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 2].name,
2153 exp->elts[pc + 1].block,
2158 if (n_candidates > 1)
2160 /* Types tend to get re-introduced locally, so if there
2161 are any local symbols that are not types, first filter
2164 for (j = 0; j < n_candidates; j += 1)
2165 switch (SYMBOL_CLASS (candidate_syms[j]))
2171 case LOC_REGPARM_ADDR:
2175 case LOC_BASEREG_ARG:
2177 case LOC_COMPUTED_ARG:
2183 if (j < n_candidates)
2186 while (j < n_candidates)
2188 if (SYMBOL_CLASS (candidate_syms[j]) == LOC_TYPEDEF)
2190 candidate_syms[j] = candidate_syms[n_candidates-1];
2191 candidate_blocks[j] = candidate_blocks[n_candidates-1];
2200 if (n_candidates == 0)
2201 error ("No definition found for %s",
2202 ada_demangle (exp->elts[pc + 2].name));
2203 else if (n_candidates == 1)
2205 else if (deprocedure_p
2206 && ! is_nonfunction (candidate_syms, n_candidates))
2208 i = ada_resolve_function (candidate_syms, candidate_blocks,
2209 n_candidates, NULL, 0,
2210 exp->elts[pc + 2].name, context_type);
2212 error ("Could not find a match for %s",
2213 ada_demangle (exp->elts[pc + 2].name));
2217 printf_filtered ("Multiple matches for %s\n",
2218 ada_demangle (exp->elts[pc+2].name));
2219 user_select_syms (candidate_syms, candidate_blocks,
2224 exp->elts[pc].opcode = exp->elts[pc + 3].opcode = OP_VAR_VALUE;
2225 exp->elts[pc + 1].block = candidate_blocks[i];
2226 exp->elts[pc + 2].symbol = candidate_syms[i];
2227 if (innermost_block == NULL ||
2228 contained_in (candidate_blocks[i], innermost_block))
2229 innermost_block = candidate_blocks[i];
2234 if (deprocedure_p
&&
2235 TYPE_CODE (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
)) ==
2238 replace_operator_with_call (expp
, pc
, 0, 0,
2239 exp
->elts
[pc
+ 2].symbol
,
2240 exp
->elts
[pc
+ 1].block
);
2247 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
2248 /* if (exp->elts[pc+3].opcode == OP_UNRESOLVED_VALUE)
2250 struct symbol** candidate_syms;
2251 struct block** candidate_blocks;
2254 n_candidates = ada_lookup_symbol_list (exp->elts[pc + 5].name,
2255 exp->elts[pc + 4].block,
2259 if (n_candidates == 1)
2263 i = ada_resolve_function (candidate_syms, candidate_blocks,
2264 n_candidates, argvec, nargs-1,
2265 exp->elts[pc + 5].name, context_type);
2267 error ("Could not find a match for %s",
2268 ada_demangle (exp->elts[pc + 5].name));
2271 exp->elts[pc + 3].opcode = exp->elts[pc + 6].opcode = OP_VAR_VALUE;
2272 exp->elts[pc + 4].block = candidate_blocks[i];
2273 exp->elts[pc + 5].symbol = candidate_syms[i];
2274 if (innermost_block == NULL ||
2275 contained_in (candidate_blocks[i], innermost_block))
2276 innermost_block = candidate_blocks[i];
2288 case BINOP_BITWISE_AND
:
2289 case BINOP_BITWISE_IOR
:
2290 case BINOP_BITWISE_XOR
:
2292 case BINOP_NOTEQUAL
:
2300 case UNOP_LOGICAL_NOT
:
2302 if (possible_user_operator_p (op
, argvec
))
2304 struct symbol
**candidate_syms
;
2305 struct block
**candidate_blocks
;
2309 ada_lookup_symbol_list (ada_mangle (ada_op_name (op
)),
2310 (struct block
*) NULL
, VAR_DOMAIN
,
2311 &candidate_syms
, &candidate_blocks
);
2313 ada_resolve_function (candidate_syms
, candidate_blocks
,
2314 n_candidates
, argvec
, nargs
,
2315 ada_op_name (op
), NULL
);
2319 replace_operator_with_call (expp
, pc
, nargs
, 1,
2320 candidate_syms
[i
], candidate_blocks
[i
]);
2327 return evaluate_subexp_type (exp
, pos
);
2330 /* Return non-zero if formal type FTYPE matches actual type ATYPE. If
2331 MAY_DEREF is non-zero, the formal may be a pointer and the actual
2333 /* The term "match" here is rather loose. The match is heuristic and
2334 liberal. FIXME: TOO liberal, in fact. */
2337 ada_type_match (struct type
*ftype
, struct type
*atype
, int may_deref
)
2339 CHECK_TYPEDEF (ftype
);
2340 CHECK_TYPEDEF (atype
);
2342 if (TYPE_CODE (ftype
) == TYPE_CODE_REF
)
2343 ftype
= TYPE_TARGET_TYPE (ftype
);
2344 if (TYPE_CODE (atype
) == TYPE_CODE_REF
)
2345 atype
= TYPE_TARGET_TYPE (atype
);
2347 if (TYPE_CODE (ftype
) == TYPE_CODE_VOID
2348 || TYPE_CODE (atype
) == TYPE_CODE_VOID
)
2351 switch (TYPE_CODE (ftype
))
2356 if (TYPE_CODE (atype
) == TYPE_CODE_PTR
)
2357 return ada_type_match (TYPE_TARGET_TYPE (ftype
),
2358 TYPE_TARGET_TYPE (atype
), 0);
2360 return (may_deref
&&
2361 ada_type_match (TYPE_TARGET_TYPE (ftype
), atype
, 0));
2363 case TYPE_CODE_ENUM
:
2364 case TYPE_CODE_RANGE
:
2365 switch (TYPE_CODE (atype
))
2368 case TYPE_CODE_ENUM
:
2369 case TYPE_CODE_RANGE
:
2375 case TYPE_CODE_ARRAY
:
2376 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2377 || ada_is_array_descriptor (atype
));
2379 case TYPE_CODE_STRUCT
:
2380 if (ada_is_array_descriptor (ftype
))
2381 return (TYPE_CODE (atype
) == TYPE_CODE_ARRAY
2382 || ada_is_array_descriptor (atype
));
2384 return (TYPE_CODE (atype
) == TYPE_CODE_STRUCT
2385 && !ada_is_array_descriptor (atype
));
2387 case TYPE_CODE_UNION
:
2389 return (TYPE_CODE (atype
) == TYPE_CODE (ftype
));
2393 /* Return non-zero if the formals of FUNC "sufficiently match" the
2394 vector of actual argument types ACTUALS of size N_ACTUALS. FUNC
2395 may also be an enumeral, in which case it is treated as a 0-
2396 argument function. */
2399 ada_args_match (struct symbol
*func
, struct value
**actuals
, int n_actuals
)
2402 struct type
*func_type
= SYMBOL_TYPE (func
);
2404 if (SYMBOL_CLASS (func
) == LOC_CONST
&&
2405 TYPE_CODE (func_type
) == TYPE_CODE_ENUM
)
2406 return (n_actuals
== 0);
2407 else if (func_type
== NULL
|| TYPE_CODE (func_type
) != TYPE_CODE_FUNC
)
2410 if (TYPE_NFIELDS (func_type
) != n_actuals
)
2413 for (i
= 0; i
< n_actuals
; i
+= 1)
2415 struct type
*ftype
= check_typedef (TYPE_FIELD_TYPE (func_type
, i
));
2416 struct type
*atype
= check_typedef (VALUE_TYPE (actuals
[i
]));
2418 if (!ada_type_match (TYPE_FIELD_TYPE (func_type
, i
),
2419 VALUE_TYPE (actuals
[i
]), 1))
2425 /* False iff function type FUNC_TYPE definitely does not produce a value
2426 compatible with type CONTEXT_TYPE. Conservatively returns 1 if
2427 FUNC_TYPE is not a valid function type with a non-null return type
2428 or an enumerated type. A null CONTEXT_TYPE indicates any non-void type. */
2431 return_match (struct type
*func_type
, struct type
*context_type
)
2433 struct type
*return_type
;
2435 if (func_type
== NULL
)
2438 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2439 /* if (TYPE_CODE (func_type) == TYPE_CODE_FUNC)
2440 return_type = base_type (TYPE_TARGET_TYPE (func_type));
2442 return_type = base_type (func_type); */
2443 if (return_type
== NULL
)
2446 /* FIXME: base_type should be declared in gdbtypes.h, implemented in valarith.c */
2447 /* context_type = base_type (context_type); */
2449 if (TYPE_CODE (return_type
) == TYPE_CODE_ENUM
)
2450 return context_type
== NULL
|| return_type
== context_type
;
2451 else if (context_type
== NULL
)
2452 return TYPE_CODE (return_type
) != TYPE_CODE_VOID
;
2454 return TYPE_CODE (return_type
) == TYPE_CODE (context_type
);
2458 /* Return the index in SYMS[0..NSYMS-1] of symbol for the
2459 function (if any) that matches the types of the NARGS arguments in
2460 ARGS. If CONTEXT_TYPE is non-null, and there is at least one match
2461 that returns type CONTEXT_TYPE, then eliminate other matches. If
2462 CONTEXT_TYPE is null, prefer a non-void-returning function.
2463 Asks the user if there is more than one match remaining. Returns -1
2464 if there is no such symbol or none is selected. NAME is used
2465 solely for messages. May re-arrange and modify SYMS in
2466 the process; the index returned is for the modified vector. BLOCKS
2467 is modified in parallel to SYMS. */
2470 ada_resolve_function (struct symbol
*syms
[], struct block
*blocks
[],
2471 int nsyms
, struct value
**args
, int nargs
,
2472 const char *name
, struct type
*context_type
)
2475 int m
; /* Number of hits */
2476 struct type
*fallback
;
2477 struct type
*return_type
;
2479 return_type
= context_type
;
2480 if (context_type
== NULL
)
2481 fallback
= builtin_type_void
;
2488 for (k
= 0; k
< nsyms
; k
+= 1)
2490 struct type
*type
= check_typedef (SYMBOL_TYPE (syms
[k
]));
2492 if (ada_args_match (syms
[k
], args
, nargs
)
2493 && return_match (SYMBOL_TYPE (syms
[k
]), return_type
))
2497 blocks
[m
] = blocks
[k
];
2501 if (m
> 0 || return_type
== fallback
)
2504 return_type
= fallback
;
2511 printf_filtered ("Multiple matches for %s\n", name
);
2512 user_select_syms (syms
, blocks
, m
, 1);
2518 /* Returns true (non-zero) iff demangled name N0 should appear before N1 */
2519 /* in a listing of choices during disambiguation (see sort_choices, below). */
2520 /* The idea is that overloadings of a subprogram name from the */
2521 /* same package should sort in their source order. We settle for ordering */
2522 /* such symbols by their trailing number (__N or $N). */
2524 mangled_ordered_before (char *N0
, char *N1
)
2528 else if (N0
== NULL
)
2533 for (k0
= strlen (N0
) - 1; k0
> 0 && isdigit (N0
[k0
]); k0
-= 1)
2535 for (k1
= strlen (N1
) - 1; k1
> 0 && isdigit (N1
[k1
]); k1
-= 1)
2537 if ((N0
[k0
] == '_' || N0
[k0
] == '$') && N0
[k0
+ 1] != '\000'
2538 && (N1
[k1
] == '_' || N1
[k1
] == '$') && N1
[k1
+ 1] != '\000')
2542 while (N0
[n0
] == '_' && n0
> 0 && N0
[n0
- 1] == '_')
2545 while (N1
[n1
] == '_' && n1
> 0 && N1
[n1
- 1] == '_')
2547 if (n0
== n1
&& STREQN (N0
, N1
, n0
))
2548 return (atoi (N0
+ k0
+ 1) < atoi (N1
+ k1
+ 1));
2550 return (strcmp (N0
, N1
) < 0);
2554 /* Sort SYMS[0..NSYMS-1] to put the choices in a canonical order by their */
2555 /* mangled names, rearranging BLOCKS[0..NSYMS-1] according to the same */
2558 sort_choices (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
)
2561 for (i
= 1; i
< nsyms
; i
+= 1)
2563 struct symbol
*sym
= syms
[i
];
2564 struct block
*block
= blocks
[i
];
2567 for (j
= i
- 1; j
>= 0; j
-= 1)
2569 if (mangled_ordered_before (DEPRECATED_SYMBOL_NAME (syms
[j
]),
2570 DEPRECATED_SYMBOL_NAME (sym
)))
2572 syms
[j
+ 1] = syms
[j
];
2573 blocks
[j
+ 1] = blocks
[j
];
2576 blocks
[j
+ 1] = block
;
2580 /* Given a list of NSYMS symbols in SYMS and corresponding blocks in */
2581 /* BLOCKS, select up to MAX_RESULTS>0 by asking the user (if */
2582 /* necessary), returning the number selected, and setting the first */
2583 /* elements of SYMS and BLOCKS to the selected symbols and */
2584 /* corresponding blocks. Error if no symbols selected. BLOCKS may */
2585 /* be NULL, in which case it is ignored. */
2587 /* NOTE: Adapted from decode_line_2 in symtab.c, with which it ought
2588 to be re-integrated one of these days. */
2591 user_select_syms (struct symbol
*syms
[], struct block
*blocks
[], int nsyms
,
2595 int *chosen
= (int *) alloca (sizeof (int) * nsyms
);
2597 int first_choice
= (max_results
== 1) ? 1 : 2;
2599 if (max_results
< 1)
2600 error ("Request to select 0 symbols!");
2604 printf_unfiltered ("[0] cancel\n");
2605 if (max_results
> 1)
2606 printf_unfiltered ("[1] all\n");
2608 sort_choices (syms
, blocks
, nsyms
);
2610 for (i
= 0; i
< nsyms
; i
+= 1)
2612 if (syms
[i
] == NULL
)
2615 if (SYMBOL_CLASS (syms
[i
]) == LOC_BLOCK
)
2617 struct symtab_and_line sal
= find_function_start_sal (syms
[i
], 1);
2618 printf_unfiltered ("[%d] %s at %s:%d\n",
2620 SYMBOL_PRINT_NAME (syms
[i
]),
2622 ? "<no source file available>"
2623 : sal
.symtab
->filename
, sal
.line
);
2629 (SYMBOL_CLASS (syms
[i
]) == LOC_CONST
2630 && SYMBOL_TYPE (syms
[i
]) != NULL
2631 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) == TYPE_CODE_ENUM
);
2632 struct symtab
*symtab
= symtab_for_sym (syms
[i
]);
2634 if (SYMBOL_LINE (syms
[i
]) != 0 && symtab
!= NULL
)
2635 printf_unfiltered ("[%d] %s at %s:%d\n",
2637 SYMBOL_PRINT_NAME (syms
[i
]),
2638 symtab
->filename
, SYMBOL_LINE (syms
[i
]));
2639 else if (is_enumeral
&& TYPE_NAME (SYMBOL_TYPE (syms
[i
])) != NULL
)
2641 printf_unfiltered ("[%d] ", i
+ first_choice
);
2642 ada_print_type (SYMBOL_TYPE (syms
[i
]), NULL
, gdb_stdout
, -1, 0);
2643 printf_unfiltered ("'(%s) (enumeral)\n",
2644 SYMBOL_PRINT_NAME (syms
[i
]));
2646 else if (symtab
!= NULL
)
2647 printf_unfiltered (is_enumeral
2648 ? "[%d] %s in %s (enumeral)\n"
2649 : "[%d] %s at %s:?\n",
2651 SYMBOL_PRINT_NAME (syms
[i
]),
2654 printf_unfiltered (is_enumeral
2655 ? "[%d] %s (enumeral)\n"
2658 SYMBOL_PRINT_NAME (syms
[i
]));
2662 n_chosen
= get_selections (chosen
, nsyms
, max_results
, max_results
> 1,
2665 for (i
= 0; i
< n_chosen
; i
+= 1)
2667 syms
[i
] = syms
[chosen
[i
]];
2669 blocks
[i
] = blocks
[chosen
[i
]];
2675 /* Read and validate a set of numeric choices from the user in the
2676 range 0 .. N_CHOICES-1. Place the results in increasing
2677 order in CHOICES[0 .. N-1], and return N.
2679 The user types choices as a sequence of numbers on one line
2680 separated by blanks, encoding them as follows:
2682 + A choice of 0 means to cancel the selection, throwing an error.
2683 + If IS_ALL_CHOICE, a choice of 1 selects the entire set 0 .. N_CHOICES-1.
2684 + The user chooses k by typing k+IS_ALL_CHOICE+1.
2686 The user is not allowed to choose more than MAX_RESULTS values.
2688 ANNOTATION_SUFFIX, if present, is used to annotate the input
2689 prompts (for use with the -f switch). */
2692 get_selections (int *choices
, int n_choices
, int max_results
,
2693 int is_all_choice
, char *annotation_suffix
)
2699 int first_choice
= is_all_choice
? 2 : 1;
2701 prompt
= getenv ("PS2");
2705 printf_unfiltered ("%s ", prompt
);
2706 gdb_flush (gdb_stdout
);
2708 args
= command_line_input ((char *) NULL
, 0, annotation_suffix
);
2711 error_no_arg ("one or more choice numbers");
2715 /* Set choices[0 .. n_chosen-1] to the users' choices in ascending
2716 order, as given in args. Choices are validated. */
2722 while (isspace (*args
))
2724 if (*args
== '\0' && n_chosen
== 0)
2725 error_no_arg ("one or more choice numbers");
2726 else if (*args
== '\0')
2729 choice
= strtol (args
, &args2
, 10);
2730 if (args
== args2
|| choice
< 0
2731 || choice
> n_choices
+ first_choice
- 1)
2732 error ("Argument must be choice number");
2736 error ("cancelled");
2738 if (choice
< first_choice
)
2740 n_chosen
= n_choices
;
2741 for (j
= 0; j
< n_choices
; j
+= 1)
2745 choice
-= first_choice
;
2747 for (j
= n_chosen
- 1; j
>= 0 && choice
< choices
[j
]; j
-= 1)
2751 if (j
< 0 || choice
!= choices
[j
])
2754 for (k
= n_chosen
- 1; k
> j
; k
-= 1)
2755 choices
[k
+ 1] = choices
[k
];
2756 choices
[j
+ 1] = choice
;
2761 if (n_chosen
> max_results
)
2762 error ("Select no more than %d of the above", max_results
);
2767 /* Replace the operator of length OPLEN at position PC in *EXPP with a call */
2768 /* on the function identified by SYM and BLOCK, and taking NARGS */
2769 /* arguments. Update *EXPP as needed to hold more space. */
2772 replace_operator_with_call (struct expression
**expp
, int pc
, int nargs
,
2773 int oplen
, struct symbol
*sym
,
2774 struct block
*block
)
2776 /* A new expression, with 6 more elements (3 for funcall, 4 for function
2777 symbol, -oplen for operator being replaced). */
2778 struct expression
*newexp
= (struct expression
*)
2779 xmalloc (sizeof (struct expression
)
2780 + EXP_ELEM_TO_BYTES ((*expp
)->nelts
+ 7 - oplen
));
2781 struct expression
*exp
= *expp
;
2783 newexp
->nelts
= exp
->nelts
+ 7 - oplen
;
2784 newexp
->language_defn
= exp
->language_defn
;
2785 memcpy (newexp
->elts
, exp
->elts
, EXP_ELEM_TO_BYTES (pc
));
2786 memcpy (newexp
->elts
+ pc
+ 7, exp
->elts
+ pc
+ oplen
,
2787 EXP_ELEM_TO_BYTES (exp
->nelts
- pc
- oplen
));
2789 newexp
->elts
[pc
].opcode
= newexp
->elts
[pc
+ 2].opcode
= OP_FUNCALL
;
2790 newexp
->elts
[pc
+ 1].longconst
= (LONGEST
) nargs
;
2792 newexp
->elts
[pc
+ 3].opcode
= newexp
->elts
[pc
+ 6].opcode
= OP_VAR_VALUE
;
2793 newexp
->elts
[pc
+ 4].block
= block
;
2794 newexp
->elts
[pc
+ 5].symbol
= sym
;
2800 /* Type-class predicates */
2802 /* True iff TYPE is numeric (i.e., an INT, RANGE (of numeric type), or */
2806 numeric_type_p (struct type
*type
)
2812 switch (TYPE_CODE (type
))
2817 case TYPE_CODE_RANGE
:
2818 return (type
== TYPE_TARGET_TYPE (type
)
2819 || numeric_type_p (TYPE_TARGET_TYPE (type
)));
2826 /* True iff TYPE is integral (an INT or RANGE of INTs). */
2829 integer_type_p (struct type
*type
)
2835 switch (TYPE_CODE (type
))
2839 case TYPE_CODE_RANGE
:
2840 return (type
== TYPE_TARGET_TYPE (type
)
2841 || integer_type_p (TYPE_TARGET_TYPE (type
)));
2848 /* True iff TYPE is scalar (INT, RANGE, FLOAT, ENUM). */
2851 scalar_type_p (struct type
*type
)
2857 switch (TYPE_CODE (type
))
2860 case TYPE_CODE_RANGE
:
2861 case TYPE_CODE_ENUM
:
2870 /* True iff TYPE is discrete (INT, RANGE, ENUM). */
2873 discrete_type_p (struct type
*type
)
2879 switch (TYPE_CODE (type
))
2882 case TYPE_CODE_RANGE
:
2883 case TYPE_CODE_ENUM
:
2891 /* Returns non-zero if OP with operatands in the vector ARGS could be
2892 a user-defined function. Errs on the side of pre-defined operators
2893 (i.e., result 0). */
2896 possible_user_operator_p (enum exp_opcode op
, struct value
*args
[])
2898 struct type
*type0
= check_typedef (VALUE_TYPE (args
[0]));
2899 struct type
*type1
=
2900 (args
[1] == NULL
) ? NULL
: check_typedef (VALUE_TYPE (args
[1]));
2911 return (!(numeric_type_p (type0
) && numeric_type_p (type1
)));
2915 case BINOP_BITWISE_AND
:
2916 case BINOP_BITWISE_IOR
:
2917 case BINOP_BITWISE_XOR
:
2918 return (!(integer_type_p (type0
) && integer_type_p (type1
)));
2921 case BINOP_NOTEQUAL
:
2926 return (!(scalar_type_p (type0
) && scalar_type_p (type1
)));
2929 return ((TYPE_CODE (type0
) != TYPE_CODE_ARRAY
&&
2930 (TYPE_CODE (type0
) != TYPE_CODE_PTR
||
2931 TYPE_CODE (TYPE_TARGET_TYPE (type0
))
2932 != TYPE_CODE_ARRAY
))
2933 || (TYPE_CODE (type1
) != TYPE_CODE_ARRAY
&&
2934 (TYPE_CODE (type1
) != TYPE_CODE_PTR
||
2935 TYPE_CODE (TYPE_TARGET_TYPE (type1
)) != TYPE_CODE_ARRAY
)));
2938 return (!(numeric_type_p (type0
) && integer_type_p (type1
)));
2942 case UNOP_LOGICAL_NOT
:
2944 return (!numeric_type_p (type0
));
2951 /** NOTE: In the following, we assume that a renaming type's name may
2952 * have an ___XD suffix. It would be nice if this went away at some
2955 /* If TYPE encodes a renaming, returns the renaming suffix, which
2956 * is XR for an object renaming, XRP for a procedure renaming, XRE for
2957 * an exception renaming, and XRS for a subprogram renaming. Returns
2958 * NULL if NAME encodes none of these. */
2960 ada_renaming_type (struct type
*type
)
2962 if (type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_ENUM
)
2964 const char *name
= type_name_no_tag (type
);
2965 const char *suffix
= (name
== NULL
) ? NULL
: strstr (name
, "___XR");
2967 || (suffix
[5] != '\000' && strchr ("PES_", suffix
[5]) == NULL
))
2976 /* Return non-zero iff SYM encodes an object renaming. */
2978 ada_is_object_renaming (struct symbol
*sym
)
2980 const char *renaming_type
= ada_renaming_type (SYMBOL_TYPE (sym
));
2981 return renaming_type
!= NULL
2982 && (renaming_type
[2] == '\0' || renaming_type
[2] == '_');
2985 /* Assuming that SYM encodes a non-object renaming, returns the original
2986 * name of the renamed entity. The name is good until the end of
2989 ada_simple_renamed_entity (struct symbol
*sym
)
2992 const char *raw_name
;
2996 type
= SYMBOL_TYPE (sym
);
2997 if (type
== NULL
|| TYPE_NFIELDS (type
) < 1)
2998 error ("Improperly encoded renaming.");
3000 raw_name
= TYPE_FIELD_NAME (type
, 0);
3001 len
= (raw_name
== NULL
? 0 : strlen (raw_name
)) - 5;
3003 error ("Improperly encoded renaming.");
3005 result
= xmalloc (len
+ 1);
3006 /* FIXME: add_name_string_cleanup should be defined in parse.c */
3007 /* add_name_string_cleanup (result); */
3008 strncpy (result
, raw_name
, len
);
3009 result
[len
] = '\000';
3014 /* Evaluation: Function Calls */
3016 /* Copy VAL onto the stack, using and updating *SP as the stack
3017 pointer. Return VAL as an lvalue. */
3019 static struct value
*
3020 place_on_stack (struct value
*val
, CORE_ADDR
*sp
)
3022 CORE_ADDR old_sp
= *sp
;
3025 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3026 STACK_ALIGN (TYPE_LENGTH
3027 (check_typedef (VALUE_TYPE (val
)))));
3029 *sp
= push_bytes (*sp
, VALUE_CONTENTS_RAW (val
),
3030 TYPE_LENGTH (check_typedef (VALUE_TYPE (val
))));
3033 VALUE_LVAL (val
) = lval_memory
;
3034 if (INNER_THAN (1, 2))
3035 VALUE_ADDRESS (val
) = *sp
;
3037 VALUE_ADDRESS (val
) = old_sp
;
3042 /* Return the value ACTUAL, converted to be an appropriate value for a
3043 formal of type FORMAL_TYPE. Use *SP as a stack pointer for
3044 allocating any necessary descriptors (fat pointers), or copies of
3045 values not residing in memory, updating it as needed. */
3047 static struct value
*
3048 convert_actual (struct value
*actual
, struct type
*formal_type0
,
3051 struct type
*actual_type
= check_typedef (VALUE_TYPE (actual
));
3052 struct type
*formal_type
= check_typedef (formal_type0
);
3053 struct type
*formal_target
=
3054 TYPE_CODE (formal_type
) == TYPE_CODE_PTR
3055 ? check_typedef (TYPE_TARGET_TYPE (formal_type
)) : formal_type
;
3056 struct type
*actual_target
=
3057 TYPE_CODE (actual_type
) == TYPE_CODE_PTR
3058 ? check_typedef (TYPE_TARGET_TYPE (actual_type
)) : actual_type
;
3060 if (ada_is_array_descriptor (formal_target
)
3061 && TYPE_CODE (actual_target
) == TYPE_CODE_ARRAY
)
3062 return make_array_descriptor (formal_type
, actual
, sp
);
3063 else if (TYPE_CODE (formal_type
) == TYPE_CODE_PTR
)
3065 if (TYPE_CODE (formal_target
) == TYPE_CODE_ARRAY
3066 && ada_is_array_descriptor (actual_target
))
3067 return desc_data (actual
);
3068 else if (TYPE_CODE (actual_type
) != TYPE_CODE_PTR
)
3070 if (VALUE_LVAL (actual
) != lval_memory
)
3073 actual_type
= check_typedef (VALUE_TYPE (actual
));
3074 val
= allocate_value (actual_type
);
3075 memcpy ((char *) VALUE_CONTENTS_RAW (val
),
3076 (char *) VALUE_CONTENTS (actual
),
3077 TYPE_LENGTH (actual_type
));
3078 actual
= place_on_stack (val
, sp
);
3080 return value_addr (actual
);
3083 else if (TYPE_CODE (actual_type
) == TYPE_CODE_PTR
)
3084 return ada_value_ind (actual
);
3090 /* Push a descriptor of type TYPE for array value ARR on the stack at
3091 *SP, updating *SP to reflect the new descriptor. Return either
3092 an lvalue representing the new descriptor, or (if TYPE is a pointer-
3093 to-descriptor type rather than a descriptor type), a struct value*
3094 representing a pointer to this descriptor. */
3096 static struct value
*
3097 make_array_descriptor (struct type
*type
, struct value
*arr
, CORE_ADDR
*sp
)
3099 struct type
*bounds_type
= desc_bounds_type (type
);
3100 struct type
*desc_type
= desc_base_type (type
);
3101 struct value
*descriptor
= allocate_value (desc_type
);
3102 struct value
*bounds
= allocate_value (bounds_type
);
3103 CORE_ADDR bounds_addr
;
3106 for (i
= ada_array_arity (check_typedef (VALUE_TYPE (arr
))); i
> 0; i
-= 1)
3108 modify_general_field (VALUE_CONTENTS (bounds
),
3109 value_as_long (ada_array_bound (arr
, i
, 0)),
3110 desc_bound_bitpos (bounds_type
, i
, 0),
3111 desc_bound_bitsize (bounds_type
, i
, 0));
3112 modify_general_field (VALUE_CONTENTS (bounds
),
3113 value_as_long (ada_array_bound (arr
, i
, 1)),
3114 desc_bound_bitpos (bounds_type
, i
, 1),
3115 desc_bound_bitsize (bounds_type
, i
, 1));
3118 bounds
= place_on_stack (bounds
, sp
);
3120 modify_general_field (VALUE_CONTENTS (descriptor
),
3122 fat_pntr_data_bitpos (desc_type
),
3123 fat_pntr_data_bitsize (desc_type
));
3124 modify_general_field (VALUE_CONTENTS (descriptor
),
3125 VALUE_ADDRESS (bounds
),
3126 fat_pntr_bounds_bitpos (desc_type
),
3127 fat_pntr_bounds_bitsize (desc_type
));
3129 descriptor
= place_on_stack (descriptor
, sp
);
3131 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
3132 return value_addr (descriptor
);
3138 /* Assuming a dummy frame has been established on the target, perform any
3139 conversions needed for calling function FUNC on the NARGS actual
3140 parameters in ARGS, other than standard C conversions. Does
3141 nothing if FUNC does not have Ada-style prototype data, or if NARGS
3142 does not match the number of arguments expected. Use *SP as a
3143 stack pointer for additional data that must be pushed, updating its
3147 ada_convert_actuals (struct value
*func
, int nargs
, struct value
*args
[],
3152 if (TYPE_NFIELDS (VALUE_TYPE (func
)) == 0
3153 || nargs
!= TYPE_NFIELDS (VALUE_TYPE (func
)))
3156 for (i
= 0; i
< nargs
; i
+= 1)
3158 convert_actual (args
[i
], TYPE_FIELD_TYPE (VALUE_TYPE (func
), i
), sp
);
3165 /* The vectors of symbols and blocks ultimately returned from */
3166 /* ada_lookup_symbol_list. */
3168 /* Current size of defn_symbols and defn_blocks */
3169 static size_t defn_vector_size
= 0;
3171 /* Current number of symbols found. */
3172 static int ndefns
= 0;
3174 static struct symbol
**defn_symbols
= NULL
;
3175 static struct block
**defn_blocks
= NULL
;
3177 /* Return the result of a standard (literal, C-like) lookup of NAME in
3180 static struct symbol
*
3181 standard_lookup (const char *name
, domain_enum domain
)
3184 sym
= lookup_symbol (name
, (struct block
*) NULL
, domain
, 0, NULL
);
3189 /* Non-zero iff there is at least one non-function/non-enumeral symbol */
3190 /* in SYMS[0..N-1]. We treat enumerals as functions, since they */
3191 /* contend in overloading in the same way. */
3193 is_nonfunction (struct symbol
*syms
[], int n
)
3197 for (i
= 0; i
< n
; i
+= 1)
3198 if (TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_FUNC
3199 && TYPE_CODE (SYMBOL_TYPE (syms
[i
])) != TYPE_CODE_ENUM
)
3205 /* If true (non-zero), then TYPE0 and TYPE1 represent equivalent
3206 struct types. Otherwise, they may not. */
3209 equiv_types (struct type
*type0
, struct type
*type1
)
3213 if (type0
== NULL
|| type1
== NULL
3214 || TYPE_CODE (type0
) != TYPE_CODE (type1
))
3216 if ((TYPE_CODE (type0
) == TYPE_CODE_STRUCT
3217 || TYPE_CODE (type0
) == TYPE_CODE_ENUM
)
3218 && ada_type_name (type0
) != NULL
&& ada_type_name (type1
) != NULL
3219 && STREQ (ada_type_name (type0
), ada_type_name (type1
)))
3225 /* True iff SYM0 represents the same entity as SYM1, or one that is
3226 no more defined than that of SYM1. */
3229 lesseq_defined_than (struct symbol
*sym0
, struct symbol
*sym1
)
3233 if (SYMBOL_DOMAIN (sym0
) != SYMBOL_DOMAIN (sym1
)
3234 || SYMBOL_CLASS (sym0
) != SYMBOL_CLASS (sym1
))
3237 switch (SYMBOL_CLASS (sym0
))
3243 struct type
*type0
= SYMBOL_TYPE (sym0
);
3244 struct type
*type1
= SYMBOL_TYPE (sym1
);
3245 char *name0
= DEPRECATED_SYMBOL_NAME (sym0
);
3246 char *name1
= DEPRECATED_SYMBOL_NAME (sym1
);
3247 int len0
= strlen (name0
);
3249 TYPE_CODE (type0
) == TYPE_CODE (type1
)
3250 && (equiv_types (type0
, type1
)
3251 || (len0
< strlen (name1
) && STREQN (name0
, name1
, len0
)
3252 && STREQN (name1
+ len0
, "___XV", 5)));
3255 return SYMBOL_VALUE (sym0
) == SYMBOL_VALUE (sym1
)
3256 && equiv_types (SYMBOL_TYPE (sym0
), SYMBOL_TYPE (sym1
));
3262 /* Append SYM to the end of defn_symbols, and BLOCK to the end of
3263 defn_blocks, updating ndefns, and expanding defn_symbols and
3264 defn_blocks as needed. Do not include SYM if it is a duplicate. */
3267 add_defn_to_vec (struct symbol
*sym
, struct block
*block
)
3272 if (SYMBOL_TYPE (sym
) != NULL
)
3273 CHECK_TYPEDEF (SYMBOL_TYPE (sym
));
3274 for (i
= 0; i
< ndefns
; i
+= 1)
3276 if (lesseq_defined_than (sym
, defn_symbols
[i
]))
3278 else if (lesseq_defined_than (defn_symbols
[i
], sym
))
3280 defn_symbols
[i
] = sym
;
3281 defn_blocks
[i
] = block
;
3286 tmp
= defn_vector_size
;
3287 GROW_VECT (defn_symbols
, tmp
, ndefns
+ 2);
3288 GROW_VECT (defn_blocks
, defn_vector_size
, ndefns
+ 2);
3290 defn_symbols
[ndefns
] = sym
;
3291 defn_blocks
[ndefns
] = block
;
3295 /* Look, in partial_symtab PST, for symbol NAME in given domain.
3296 Check the global symbols if GLOBAL, the static symbols if not. Do
3297 wild-card match if WILD. */
3299 static struct partial_symbol
*
3300 ada_lookup_partial_symbol (struct partial_symtab
*pst
, const char *name
,
3301 int global
, domain_enum domain
, int wild
)
3303 struct partial_symbol
**start
;
3304 int name_len
= strlen (name
);
3305 int length
= (global
? pst
->n_global_syms
: pst
->n_static_syms
);
3314 pst
->objfile
->global_psymbols
.list
+ pst
->globals_offset
:
3315 pst
->objfile
->static_psymbols
.list
+ pst
->statics_offset
);
3319 for (i
= 0; i
< length
; i
+= 1)
3321 struct partial_symbol
*psym
= start
[i
];
3323 if (SYMBOL_DOMAIN (psym
) == domain
&&
3324 wild_match (name
, name_len
, DEPRECATED_SYMBOL_NAME (psym
)))
3338 int M
= (U
+ i
) >> 1;
3339 struct partial_symbol
*psym
= start
[M
];
3340 if (DEPRECATED_SYMBOL_NAME (psym
)[0] < name
[0])
3342 else if (DEPRECATED_SYMBOL_NAME (psym
)[0] > name
[0])
3344 else if (strcmp (DEPRECATED_SYMBOL_NAME (psym
), name
) < 0)
3355 struct partial_symbol
*psym
= start
[i
];
3357 if (SYMBOL_DOMAIN (psym
) == domain
)
3359 int cmp
= strncmp (name
, DEPRECATED_SYMBOL_NAME (psym
), name_len
);
3367 && is_name_suffix (DEPRECATED_SYMBOL_NAME (psym
) + name_len
))
3380 int M
= (U
+ i
) >> 1;
3381 struct partial_symbol
*psym
= start
[M
];
3382 if (DEPRECATED_SYMBOL_NAME (psym
)[0] < '_')
3384 else if (DEPRECATED_SYMBOL_NAME (psym
)[0] > '_')
3386 else if (strcmp (DEPRECATED_SYMBOL_NAME (psym
), "_ada_") < 0)
3397 struct partial_symbol
*psym
= start
[i
];
3399 if (SYMBOL_DOMAIN (psym
) == domain
)
3403 cmp
= (int) '_' - (int) DEPRECATED_SYMBOL_NAME (psym
)[0];
3406 cmp
= strncmp ("_ada_", DEPRECATED_SYMBOL_NAME (psym
), 5);
3408 cmp
= strncmp (name
, DEPRECATED_SYMBOL_NAME (psym
) + 5, name_len
);
3417 && is_name_suffix (DEPRECATED_SYMBOL_NAME (psym
) + name_len
+ 5))
3428 /* Find a symbol table containing symbol SYM or NULL if none. */
3429 static struct symtab
*
3430 symtab_for_sym (struct symbol
*sym
)
3433 struct objfile
*objfile
;
3435 struct symbol
*tmp_sym
;
3438 ALL_SYMTABS (objfile
, s
)
3440 switch (SYMBOL_CLASS (sym
))
3448 case LOC_CONST_BYTES
:
3449 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), GLOBAL_BLOCK
);
3450 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3452 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), STATIC_BLOCK
);
3453 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3459 switch (SYMBOL_CLASS (sym
))
3465 case LOC_REGPARM_ADDR
:
3470 case LOC_BASEREG_ARG
:
3472 case LOC_COMPUTED_ARG
:
3473 for (j
= FIRST_LOCAL_BLOCK
;
3474 j
< BLOCKVECTOR_NBLOCKS (BLOCKVECTOR (s
)); j
+= 1)
3476 b
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (s
), j
);
3477 ALL_BLOCK_SYMBOLS (b
, i
, tmp_sym
) if (sym
== tmp_sym
)
3488 /* Return a minimal symbol matching NAME according to Ada demangling
3489 rules. Returns NULL if there is no such minimal symbol. */
3491 struct minimal_symbol
*
3492 ada_lookup_minimal_symbol (const char *name
)
3494 struct objfile
*objfile
;
3495 struct minimal_symbol
*msymbol
;
3496 int wild_match
= (strstr (name
, "__") == NULL
);
3498 ALL_MSYMBOLS (objfile
, msymbol
)
3500 if (ada_match_name (DEPRECATED_SYMBOL_NAME (msymbol
), name
, wild_match
)
3501 && MSYMBOL_TYPE (msymbol
) != mst_solib_trampoline
)
3508 /* For all subprograms that statically enclose the subprogram of the
3509 * selected frame, add symbols matching identifier NAME in DOMAIN
3510 * and their blocks to vectors *defn_symbols and *defn_blocks, as for
3511 * ada_add_block_symbols (q.v.). If WILD, treat as NAME with a
3512 * wildcard prefix. At the moment, this function uses a heuristic to
3513 * find the frames of enclosing subprograms: it treats the
3514 * pointer-sized value at location 0 from the local-variable base of a
3515 * frame as a static link, and then searches up the call stack for a
3516 * frame with that same local-variable base. */
3518 add_symbols_from_enclosing_procs (const char *name
, domain_enum domain
,
3522 static struct symbol static_link_sym
;
3523 static struct symbol
*static_link
;
3525 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
3526 struct frame_info
*frame
;
3527 struct frame_info
*target_frame
;
3529 if (static_link
== NULL
)
3531 /* Initialize the local variable symbol that stands for the
3532 * static link (when it exists). */
3533 static_link
= &static_link_sym
;
3534 DEPRECATED_SYMBOL_NAME (static_link
) = "";
3535 SYMBOL_LANGUAGE (static_link
) = language_unknown
;
3536 SYMBOL_CLASS (static_link
) = LOC_LOCAL
;
3537 SYMBOL_DOMAIN (static_link
) = VAR_DOMAIN
;
3538 SYMBOL_TYPE (static_link
) = lookup_pointer_type (builtin_type_void
);
3539 SYMBOL_VALUE (static_link
) =
3540 -(long) TYPE_LENGTH (SYMBOL_TYPE (static_link
));
3543 frame
= deprecated_selected_frame
;
3544 while (frame
!= NULL
&& ndefns
== 0)
3546 struct block
*block
;
3547 struct value
*target_link_val
= read_var_value (static_link
, frame
);
3548 CORE_ADDR target_link
;
3550 if (target_link_val
== NULL
)
3554 target_link
= target_link_val
;
3558 frame
= get_prev_frame (frame
);
3560 while (frame
!= NULL
&& FRAME_LOCALS_ADDRESS (frame
) != target_link
);
3565 block
= get_frame_block (frame
, 0);
3566 while (block
!= NULL
&& block_function (block
) != NULL
&& ndefns
== 0)
3568 ada_add_block_symbols (block
, name
, domain
, NULL
, wild_match
);
3570 block
= BLOCK_SUPERBLOCK (block
);
3574 do_cleanups (old_chain
);
3578 /* True if TYPE is definitely an artificial type supplied to a symbol
3579 * for which no debugging information was given in the symbol file. */
3581 is_nondebugging_type (struct type
*type
)
3583 char *name
= ada_type_name (type
);
3584 return (name
!= NULL
&& STREQ (name
, "<variable, no debug info>"));
3587 /* Remove any non-debugging symbols in SYMS[0 .. NSYMS-1] that definitely
3588 * duplicate other symbols in the list. (The only case I know of where
3589 * this happens is when object files containing stabs-in-ecoff are
3590 * linked with files containing ordinary ecoff debugging symbols (or no
3591 * debugging symbols)). Modifies SYMS to squeeze out deleted symbols,
3592 * and applies the same modification to BLOCKS to maintain the
3593 * correspondence between SYMS[i] and BLOCKS[i]. Returns the number
3594 * of symbols in the modified list. */
3596 remove_extra_symbols (struct symbol
**syms
, struct block
**blocks
, int nsyms
)
3603 if (DEPRECATED_SYMBOL_NAME (syms
[i
]) != NULL
3604 && SYMBOL_CLASS (syms
[i
]) == LOC_STATIC
3605 && is_nondebugging_type (SYMBOL_TYPE (syms
[i
])))
3607 for (j
= 0; j
< nsyms
; j
+= 1)
3610 && DEPRECATED_SYMBOL_NAME (syms
[j
]) != NULL
3611 && STREQ (DEPRECATED_SYMBOL_NAME (syms
[i
]), DEPRECATED_SYMBOL_NAME (syms
[j
]))
3612 && SYMBOL_CLASS (syms
[i
]) == SYMBOL_CLASS (syms
[j
])
3613 && SYMBOL_VALUE_ADDRESS (syms
[i
])
3614 == SYMBOL_VALUE_ADDRESS (syms
[j
]))
3617 for (k
= i
+ 1; k
< nsyms
; k
+= 1)
3619 syms
[k
- 1] = syms
[k
];
3620 blocks
[k
- 1] = blocks
[k
];
3634 /* Find symbols in DOMAIN matching NAME, in BLOCK0 and enclosing
3635 scope and in global scopes, returning the number of matches. Sets
3636 *SYMS to point to a vector of matching symbols, with *BLOCKS
3637 pointing to the vector of corresponding blocks in which those
3638 symbols reside. These two vectors are transient---good only to the
3639 next call of ada_lookup_symbol_list. Any non-function/non-enumeral symbol
3640 match within the nest of blocks whose innermost member is BLOCK0,
3641 is the outermost match returned (no other matches in that or
3642 enclosing blocks is returned). If there are any matches in or
3643 surrounding BLOCK0, then these alone are returned. */
3646 ada_lookup_symbol_list (const char *name
, struct block
*block0
,
3647 domain_enum domain
, struct symbol
***syms
,
3648 struct block
***blocks
)
3652 struct partial_symtab
*ps
;
3653 struct blockvector
*bv
;
3654 struct objfile
*objfile
;
3656 struct block
*block
;
3657 struct minimal_symbol
*msymbol
;
3658 int wild_match
= (strstr (name
, "__") == NULL
);
3668 /* Search specified block and its superiors. */
3671 while (block
!= NULL
)
3673 ada_add_block_symbols (block
, name
, domain
, NULL
, wild_match
);
3675 /* If we found a non-function match, assume that's the one. */
3676 if (is_nonfunction (defn_symbols
, ndefns
))
3679 block
= BLOCK_SUPERBLOCK (block
);
3682 /* If we found ANY matches in the specified BLOCK, we're done. */
3689 /* Now add symbols from all global blocks: symbol tables, minimal symbol
3690 tables, and psymtab's */
3692 ALL_SYMTABS (objfile
, s
)
3697 bv
= BLOCKVECTOR (s
);
3698 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3699 ada_add_block_symbols (block
, name
, domain
, objfile
, wild_match
);
3702 if (domain
== VAR_DOMAIN
)
3704 ALL_MSYMBOLS (objfile
, msymbol
)
3706 if (ada_match_name (DEPRECATED_SYMBOL_NAME (msymbol
), name
, wild_match
))
3708 switch (MSYMBOL_TYPE (msymbol
))
3710 case mst_solib_trampoline
:
3713 s
= find_pc_symtab (SYMBOL_VALUE_ADDRESS (msymbol
));
3716 int old_ndefns
= ndefns
;
3718 bv
= BLOCKVECTOR (s
);
3719 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3720 ada_add_block_symbols (block
,
3721 DEPRECATED_SYMBOL_NAME (msymbol
),
3722 domain
, objfile
, wild_match
);
3723 if (ndefns
== old_ndefns
)
3725 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3726 ada_add_block_symbols (block
,
3727 DEPRECATED_SYMBOL_NAME (msymbol
),
3737 ALL_PSYMTABS (objfile
, ps
)
3741 && ada_lookup_partial_symbol (ps
, name
, 1, domain
, wild_match
))
3743 s
= PSYMTAB_TO_SYMTAB (ps
);
3746 bv
= BLOCKVECTOR (s
);
3747 block
= BLOCKVECTOR_BLOCK (bv
, GLOBAL_BLOCK
);
3748 ada_add_block_symbols (block
, name
, domain
, objfile
, wild_match
);
3752 /* Now add symbols from all per-file blocks if we've gotten no hits.
3753 (Not strictly correct, but perhaps better than an error).
3754 Do the symtabs first, then check the psymtabs */
3759 ALL_SYMTABS (objfile
, s
)
3764 bv
= BLOCKVECTOR (s
);
3765 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3766 ada_add_block_symbols (block
, name
, domain
, objfile
, wild_match
);
3769 ALL_PSYMTABS (objfile
, ps
)
3773 && ada_lookup_partial_symbol (ps
, name
, 0, domain
, wild_match
))
3775 s
= PSYMTAB_TO_SYMTAB (ps
);
3776 bv
= BLOCKVECTOR (s
);
3779 block
= BLOCKVECTOR_BLOCK (bv
, STATIC_BLOCK
);
3780 ada_add_block_symbols (block
, name
, domain
,
3781 objfile
, wild_match
);
3786 /* Finally, we try to find NAME as a local symbol in some lexically
3787 enclosing block. We do this last, expecting this case to be
3791 add_symbols_from_enclosing_procs (name
, domain
, wild_match
);
3797 ndefns
= remove_extra_symbols (defn_symbols
, defn_blocks
, ndefns
);
3800 *syms
= defn_symbols
;
3801 *blocks
= defn_blocks
;
3808 /* Return a symbol in DOMAIN matching NAME, in BLOCK0 and enclosing
3809 * scope and in global scopes, or NULL if none. NAME is folded to
3810 * lower case first, unless it is surrounded in single quotes.
3811 * Otherwise, the result is as for ada_lookup_symbol_list, but is
3812 * disambiguated by user query if needed. */
3815 ada_lookup_symbol (const char *name
, struct block
*block0
,
3818 struct symbol
**candidate_syms
;
3819 struct block
**candidate_blocks
;
3822 n_candidates
= ada_lookup_symbol_list (name
,
3824 &candidate_syms
, &candidate_blocks
);
3826 if (n_candidates
== 0)
3828 else if (n_candidates
!= 1)
3829 user_select_syms (candidate_syms
, candidate_blocks
, n_candidates
, 1);
3831 return candidate_syms
[0];
3835 /* True iff STR is a possible encoded suffix of a normal Ada name
3836 * that is to be ignored for matching purposes. Suffixes of parallel
3837 * names (e.g., XVE) are not included here. Currently, the possible suffixes
3838 * are given by the regular expression:
3839 * (X[nb]*)?(__[0-9]+|\$[0-9]+|___(LJM|X([FDBUP].*|R[^T]?)))?$
3843 is_name_suffix (const char *str
)
3849 while (str
[0] != '_' && str
[0] != '\0')
3851 if (str
[0] != 'n' && str
[0] != 'b')
3856 if (str
[0] == '\000')
3860 if (str
[1] != '_' || str
[2] == '\000')
3864 if (STREQ (str
+ 3, "LJM"))
3868 if (str
[4] == 'F' || str
[4] == 'D' || str
[4] == 'B' ||
3869 str
[4] == 'U' || str
[4] == 'P')
3871 if (str
[4] == 'R' && str
[5] != 'T')
3875 for (k
= 2; str
[k
] != '\0'; k
+= 1)
3876 if (!isdigit (str
[k
]))
3880 if (str
[0] == '$' && str
[1] != '\000')
3882 for (k
= 1; str
[k
] != '\0'; k
+= 1)
3883 if (!isdigit (str
[k
]))
3890 /* True if NAME represents a name of the form A1.A2....An, n>=1 and
3891 * PATN[0..PATN_LEN-1] = Ak.Ak+1.....An for some k >= 1. Ignores
3892 * informational suffixes of NAME (i.e., for which is_name_suffix is
3895 wild_match (const char *patn
, int patn_len
, const char *name
)
3900 name_len
= strlen (name
);
3901 if (name_len
>= patn_len
+ 5 && STREQN (name
, "_ada_", 5)
3902 && STREQN (patn
, name
+ 5, patn_len
)
3903 && is_name_suffix (name
+ patn_len
+ 5))
3906 while (name_len
>= patn_len
)
3908 if (STREQN (patn
, name
, patn_len
) && is_name_suffix (name
+ patn_len
))
3916 && name
[0] != '.' && (name
[0] != '_' || name
[1] != '_'));
3921 if (!islower (name
[2]))
3928 if (!islower (name
[1]))
3939 /* Add symbols from BLOCK matching identifier NAME in DOMAIN to
3940 vector *defn_symbols, updating *defn_symbols (if necessary), *SZ (the size of
3941 the vector *defn_symbols), and *ndefns (the number of symbols
3942 currently stored in *defn_symbols). If WILD, treat as NAME with a
3943 wildcard prefix. OBJFILE is the section containing BLOCK. */
3946 ada_add_block_symbols (struct block
*block
, const char *name
,
3947 domain_enum domain
, struct objfile
*objfile
,
3951 int name_len
= strlen (name
);
3952 /* A matching argument symbol, if any. */
3953 struct symbol
*arg_sym
;
3954 /* Set true when we find a matching non-argument symbol */
3963 ALL_BLOCK_SYMBOLS (block
, i
, sym
)
3965 if (SYMBOL_DOMAIN (sym
) == domain
&&
3966 wild_match (name
, name_len
, DEPRECATED_SYMBOL_NAME (sym
)))
3968 switch (SYMBOL_CLASS (sym
))
3974 case LOC_REGPARM_ADDR
:
3975 case LOC_BASEREG_ARG
:
3976 case LOC_COMPUTED_ARG
:
3979 case LOC_UNRESOLVED
:
3983 fill_in_ada_prototype (sym
);
3984 add_defn_to_vec (fixup_symbol_section (sym
, objfile
), block
);
3992 ALL_BLOCK_SYMBOLS (block
, i
, sym
)
3994 if (SYMBOL_DOMAIN (sym
) == domain
)
3996 int cmp
= strncmp (name
, DEPRECATED_SYMBOL_NAME (sym
), name_len
);
3999 && is_name_suffix (DEPRECATED_SYMBOL_NAME (sym
) + name_len
))
4001 switch (SYMBOL_CLASS (sym
))
4007 case LOC_REGPARM_ADDR
:
4008 case LOC_BASEREG_ARG
:
4009 case LOC_COMPUTED_ARG
:
4012 case LOC_UNRESOLVED
:
4016 fill_in_ada_prototype (sym
);
4017 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4026 if (!found_sym
&& arg_sym
!= NULL
)
4028 fill_in_ada_prototype (arg_sym
);
4029 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4037 ALL_BLOCK_SYMBOLS (block
, i
, sym
)
4039 struct symbol
*sym
= BLOCK_SYM (block
, i
);
4041 if (SYMBOL_DOMAIN (sym
) == domain
)
4045 cmp
= (int) '_' - (int) DEPRECATED_SYMBOL_NAME (sym
)[0];
4048 cmp
= strncmp ("_ada_", DEPRECATED_SYMBOL_NAME (sym
), 5);
4050 cmp
= strncmp (name
, DEPRECATED_SYMBOL_NAME (sym
) + 5, name_len
);
4054 && is_name_suffix (DEPRECATED_SYMBOL_NAME (sym
) + name_len
+ 5))
4056 switch (SYMBOL_CLASS (sym
))
4062 case LOC_REGPARM_ADDR
:
4063 case LOC_BASEREG_ARG
:
4064 case LOC_COMPUTED_ARG
:
4067 case LOC_UNRESOLVED
:
4071 fill_in_ada_prototype (sym
);
4072 add_defn_to_vec (fixup_symbol_section (sym
, objfile
),
4080 /* NOTE: This really shouldn't be needed for _ada_ symbols.
4081 They aren't parameters, right? */
4082 if (!found_sym
&& arg_sym
!= NULL
)
4084 fill_in_ada_prototype (arg_sym
);
4085 add_defn_to_vec (fixup_symbol_section (arg_sym
, objfile
), block
);
4091 /* Function Types */
4093 /* Assuming that SYM is the symbol for a function, fill in its type
4094 with prototype information, if it is not already there. */
4097 fill_in_ada_prototype (struct symbol
*func
)
4108 || TYPE_CODE (SYMBOL_TYPE (func
)) != TYPE_CODE_FUNC
4109 || TYPE_FIELDS (SYMBOL_TYPE (func
)) != NULL
)
4112 /* We make each function type unique, so that each may have its own */
4113 /* parameter types. This particular way of doing so wastes space: */
4114 /* it would be nicer to build the argument types while the original */
4115 /* function type is being built (FIXME). */
4116 rtype
= check_typedef (TYPE_TARGET_TYPE (SYMBOL_TYPE (func
)));
4117 ftype
= alloc_type (TYPE_OBJFILE (SYMBOL_TYPE (func
)));
4118 make_function_type (rtype
, &ftype
);
4119 SYMBOL_TYPE (func
) = ftype
;
4121 b
= SYMBOL_BLOCK_VALUE (func
);
4125 TYPE_FIELDS (ftype
) =
4126 (struct field
*) xmalloc (sizeof (struct field
) * max_fields
);
4127 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4129 GROW_VECT (TYPE_FIELDS (ftype
), max_fields
, nargs
+ 1);
4131 switch (SYMBOL_CLASS (sym
))
4134 case LOC_REGPARM_ADDR
:
4135 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4136 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4137 TYPE_FIELD_STATIC_KIND (ftype
, nargs
) = 0;
4138 TYPE_FIELD_TYPE (ftype
, nargs
) =
4139 lookup_pointer_type (check_typedef (SYMBOL_TYPE (sym
)));
4140 TYPE_FIELD_NAME (ftype
, nargs
) = DEPRECATED_SYMBOL_NAME (sym
);
4148 case LOC_BASEREG_ARG
:
4149 case LOC_COMPUTED_ARG
:
4150 TYPE_FIELD_BITPOS (ftype
, nargs
) = nargs
;
4151 TYPE_FIELD_BITSIZE (ftype
, nargs
) = 0;
4152 TYPE_FIELD_STATIC_KIND (ftype
, nargs
) = 0;
4153 TYPE_FIELD_TYPE (ftype
, nargs
) = check_typedef (SYMBOL_TYPE (sym
));
4154 TYPE_FIELD_NAME (ftype
, nargs
) = DEPRECATED_SYMBOL_NAME (sym
);
4164 /* Re-allocate fields vector; if there are no fields, make the */
4165 /* fields pointer non-null anyway, to mark that this function type */
4166 /* has been filled in. */
4168 TYPE_NFIELDS (ftype
) = nargs
;
4171 static struct field dummy_field
= { 0, 0, 0, 0 };
4172 xfree (TYPE_FIELDS (ftype
));
4173 TYPE_FIELDS (ftype
) = &dummy_field
;
4177 struct field
*fields
=
4178 (struct field
*) TYPE_ALLOC (ftype
, nargs
* sizeof (struct field
));
4179 memcpy ((char *) fields
,
4180 (char *) TYPE_FIELDS (ftype
), nargs
* sizeof (struct field
));
4181 xfree (TYPE_FIELDS (ftype
));
4182 TYPE_FIELDS (ftype
) = fields
;
4187 /* Breakpoint-related */
4189 char no_symtab_msg
[] =
4190 "No symbol table is loaded. Use the \"file\" command.";
4192 /* Assuming that LINE is pointing at the beginning of an argument to
4193 'break', return a pointer to the delimiter for the initial segment
4194 of that name. This is the first ':', ' ', or end of LINE.
4197 ada_start_decode_line_1 (char *line
)
4199 /* [NOTE: strpbrk would be more elegant, but I am reluctant to be
4200 the first to use such a library function in GDB code.] */
4202 for (p
= line
; *p
!= '\000' && *p
!= ' ' && *p
!= ':'; p
+= 1)
4207 /* *SPEC points to a function and line number spec (as in a break
4208 command), following any initial file name specification.
4210 Return all symbol table/line specfications (sals) consistent with the
4211 information in *SPEC and FILE_TABLE in the
4213 + FILE_TABLE is null, or the sal refers to a line in the file
4214 named by FILE_TABLE.
4215 + If *SPEC points to an argument with a trailing ':LINENUM',
4216 then the sal refers to that line (or one following it as closely as
4218 + If *SPEC does not start with '*', the sal is in a function with
4221 Returns with 0 elements if no matching non-minimal symbols found.
4223 If *SPEC begins with a function name of the form <NAME>, then NAME
4224 is taken as a literal name; otherwise the function name is subject
4225 to the usual mangling.
4227 *SPEC is updated to point after the function/line number specification.
4229 FUNFIRSTLINE is non-zero if we desire the first line of real code
4230 in each function (this is ignored in the presence of a LINENUM spec.).
4232 If CANONICAL is non-NULL, and if any of the sals require a
4233 'canonical line spec', then *CANONICAL is set to point to an array
4234 of strings, corresponding to and equal in length to the returned
4235 list of sals, such that (*CANONICAL)[i] is non-null and contains a
4236 canonical line spec for the ith returned sal, if needed. If no
4237 canonical line specs are required and CANONICAL is non-null,
4238 *CANONICAL is set to NULL.
4240 A 'canonical line spec' is simply a name (in the format of the
4241 breakpoint command) that uniquely identifies a breakpoint position,
4242 with no further contextual information or user selection. It is
4243 needed whenever the file name, function name, and line number
4244 information supplied is insufficient for this unique
4245 identification. Currently overloaded functions, the name '*',
4246 or static functions without a filename yield a canonical line spec.
4247 The array and the line spec strings are allocated on the heap; it
4248 is the caller's responsibility to free them. */
4250 struct symtabs_and_lines
4251 ada_finish_decode_line_1 (char **spec
, struct symtab
*file_table
,
4252 int funfirstline
, char ***canonical
)
4254 struct symbol
**symbols
;
4255 struct block
**blocks
;
4256 struct block
*block
;
4257 int n_matches
, i
, line_num
;
4258 struct symtabs_and_lines selected
;
4259 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4264 char *unquoted_name
;
4266 if (file_table
== NULL
)
4267 block
= get_selected_block (NULL
);
4269 block
= BLOCKVECTOR_BLOCK (BLOCKVECTOR (file_table
), STATIC_BLOCK
);
4271 if (canonical
!= NULL
)
4272 *canonical
= (char **) NULL
;
4279 while (**spec
!= '\000' &&
4280 !strchr (ada_completer_word_break_characters
, **spec
))
4286 if (file_table
!= NULL
&& (*spec
)[0] == ':' && isdigit ((*spec
)[1]))
4288 line_num
= strtol (*spec
+ 1, spec
, 10);
4289 while (**spec
== ' ' || **spec
== '\t')
4296 error ("Wild-card function with no line number or file name.");
4298 return all_sals_for_line (file_table
->filename
, line_num
, canonical
);
4301 if (name
[0] == '\'')
4309 unquoted_name
= (char *) alloca (len
- 1);
4310 memcpy (unquoted_name
, name
+ 1, len
- 2);
4311 unquoted_name
[len
- 2] = '\000';
4316 unquoted_name
= (char *) alloca (len
+ 1);
4317 memcpy (unquoted_name
, name
, len
);
4318 unquoted_name
[len
] = '\000';
4319 lower_name
= (char *) alloca (len
+ 1);
4320 for (i
= 0; i
< len
; i
+= 1)
4321 lower_name
[i
] = tolower (name
[i
]);
4322 lower_name
[len
] = '\000';
4326 if (lower_name
!= NULL
)
4327 n_matches
= ada_lookup_symbol_list (ada_mangle (lower_name
), block
,
4328 VAR_DOMAIN
, &symbols
, &blocks
);
4330 n_matches
= ada_lookup_symbol_list (unquoted_name
, block
,
4331 VAR_DOMAIN
, &symbols
, &blocks
);
4332 if (n_matches
== 0 && line_num
>= 0)
4333 error ("No line number information found for %s.", unquoted_name
);
4334 else if (n_matches
== 0)
4336 #ifdef HPPA_COMPILER_BUG
4337 /* FIXME: See comment in symtab.c::decode_line_1 */
4339 volatile struct symtab_and_line val
;
4340 #define volatile /*nothing */
4342 struct symtab_and_line val
;
4344 struct minimal_symbol
*msymbol
;
4349 if (lower_name
!= NULL
)
4350 msymbol
= ada_lookup_minimal_symbol (ada_mangle (lower_name
));
4351 if (msymbol
== NULL
)
4352 msymbol
= ada_lookup_minimal_symbol (unquoted_name
);
4353 if (msymbol
!= NULL
)
4355 val
.pc
= SYMBOL_VALUE_ADDRESS (msymbol
);
4356 val
.section
= SYMBOL_BFD_SECTION (msymbol
);
4359 val
.pc
+= FUNCTION_START_OFFSET
;
4360 SKIP_PROLOGUE (val
.pc
);
4362 selected
.sals
= (struct symtab_and_line
*)
4363 xmalloc (sizeof (struct symtab_and_line
));
4364 selected
.sals
[0] = val
;
4369 if (!have_full_symbols () &&
4370 !have_partial_symbols () && !have_minimal_symbols ())
4371 error (no_symtab_msg
);
4373 error ("Function \"%s\" not defined.", unquoted_name
);
4374 return selected
; /* for lint */
4380 find_sal_from_funcs_and_line (file_table
->filename
, line_num
,
4381 symbols
, n_matches
);
4386 user_select_syms (symbols
, blocks
, n_matches
, n_matches
);
4389 selected
.sals
= (struct symtab_and_line
*)
4390 xmalloc (sizeof (struct symtab_and_line
) * selected
.nelts
);
4391 memset (selected
.sals
, 0, selected
.nelts
* sizeof (selected
.sals
[i
]));
4392 make_cleanup (xfree
, selected
.sals
);
4395 while (i
< selected
.nelts
)
4397 if (SYMBOL_CLASS (symbols
[i
]) == LOC_BLOCK
)
4398 selected
.sals
[i
] = find_function_start_sal (symbols
[i
], funfirstline
);
4399 else if (SYMBOL_LINE (symbols
[i
]) != 0)
4401 selected
.sals
[i
].symtab
= symtab_for_sym (symbols
[i
]);
4402 selected
.sals
[i
].line
= SYMBOL_LINE (symbols
[i
]);
4404 else if (line_num
>= 0)
4406 /* Ignore this choice */
4407 symbols
[i
] = symbols
[selected
.nelts
- 1];
4408 blocks
[i
] = blocks
[selected
.nelts
- 1];
4409 selected
.nelts
-= 1;
4413 error ("Line number not known for symbol \"%s\"", unquoted_name
);
4417 if (canonical
!= NULL
&& (line_num
>= 0 || n_matches
> 1))
4419 *canonical
= (char **) xmalloc (sizeof (char *) * selected
.nelts
);
4420 for (i
= 0; i
< selected
.nelts
; i
+= 1)
4422 extended_canonical_line_spec (selected
.sals
[i
],
4423 SYMBOL_PRINT_NAME (symbols
[i
]));
4426 discard_cleanups (old_chain
);
4430 /* The (single) sal corresponding to line LINE_NUM in a symbol table
4431 with file name FILENAME that occurs in one of the functions listed
4432 in SYMBOLS[0 .. NSYMS-1]. */
4433 static struct symtabs_and_lines
4434 find_sal_from_funcs_and_line (const char *filename
, int line_num
,
4435 struct symbol
**symbols
, int nsyms
)
4437 struct symtabs_and_lines sals
;
4438 int best_index
, best
;
4439 struct linetable
*best_linetable
;
4440 struct objfile
*objfile
;
4442 struct symtab
*best_symtab
;
4444 read_all_symtabs (filename
);
4447 best_linetable
= NULL
;
4450 ALL_SYMTABS (objfile
, s
)
4452 struct linetable
*l
;
4457 if (!STREQ (filename
, s
->filename
))
4460 ind
= find_line_in_linetable (l
, line_num
, symbols
, nsyms
, &exact
);
4470 if (best
== 0 || l
->item
[ind
].line
< best
)
4472 best
= l
->item
[ind
].line
;
4481 error ("Line number not found in designated function.");
4486 sals
.sals
= (struct symtab_and_line
*) xmalloc (sizeof (sals
.sals
[0]));
4488 init_sal (&sals
.sals
[0]);
4490 sals
.sals
[0].line
= best_linetable
->item
[best_index
].line
;
4491 sals
.sals
[0].pc
= best_linetable
->item
[best_index
].pc
;
4492 sals
.sals
[0].symtab
= best_symtab
;
4497 /* Return the index in LINETABLE of the best match for LINE_NUM whose
4498 pc falls within one of the functions denoted by SYMBOLS[0..NSYMS-1].
4499 Set *EXACTP to the 1 if the match is exact, and 0 otherwise. */
4501 find_line_in_linetable (struct linetable
*linetable
, int line_num
,
4502 struct symbol
**symbols
, int nsyms
, int *exactp
)
4504 int i
, len
, best_index
, best
;
4506 if (line_num
<= 0 || linetable
== NULL
)
4509 len
= linetable
->nitems
;
4510 for (i
= 0, best_index
= -1, best
= 0; i
< len
; i
+= 1)
4513 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4515 for (k
= 0; k
< nsyms
; k
+= 1)
4517 if (symbols
[k
] != NULL
&& SYMBOL_CLASS (symbols
[k
]) == LOC_BLOCK
4518 && item
->pc
>= BLOCK_START (SYMBOL_BLOCK_VALUE (symbols
[k
]))
4519 && item
->pc
< BLOCK_END (SYMBOL_BLOCK_VALUE (symbols
[k
])))
4526 if (item
->line
== line_num
)
4532 if (item
->line
> line_num
&& (best
== 0 || item
->line
< best
))
4543 /* Find the smallest k >= LINE_NUM such that k is a line number in
4544 LINETABLE, and k falls strictly within a named function that begins at
4545 or before LINE_NUM. Return -1 if there is no such k. */
4547 nearest_line_number_in_linetable (struct linetable
*linetable
, int line_num
)
4551 if (line_num
<= 0 || linetable
== NULL
|| linetable
->nitems
== 0)
4553 len
= linetable
->nitems
;
4560 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4562 if (item
->line
>= line_num
&& item
->line
< best
)
4565 CORE_ADDR start
, end
;
4568 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4570 if (func_name
!= NULL
&& item
->pc
< end
)
4572 if (item
->line
== line_num
)
4576 struct symbol
*sym
=
4577 standard_lookup (func_name
, VAR_DOMAIN
);
4578 if (is_plausible_func_for_line (sym
, line_num
))
4584 while (i
< len
&& linetable
->item
[i
].pc
< end
);
4594 return (best
== INT_MAX
) ? -1 : best
;
4598 /* Return the next higher index, k, into LINETABLE such that k > IND,
4599 entry k in LINETABLE has a line number equal to LINE_NUM, k
4600 corresponds to a PC that is in a function different from that
4601 corresponding to IND, and falls strictly within a named function
4602 that begins at a line at or preceding STARTING_LINE.
4603 Return -1 if there is no such k.
4604 IND == -1 corresponds to no function. */
4607 find_next_line_in_linetable (struct linetable
*linetable
, int line_num
,
4608 int starting_line
, int ind
)
4612 if (line_num
<= 0 || linetable
== NULL
|| ind
>= linetable
->nitems
)
4614 len
= linetable
->nitems
;
4618 CORE_ADDR start
, end
;
4620 if (find_pc_partial_function (linetable
->item
[ind
].pc
,
4621 (char **) NULL
, &start
, &end
))
4623 while (ind
< len
&& linetable
->item
[ind
].pc
< end
)
4636 struct linetable_entry
*item
= &(linetable
->item
[i
]);
4638 if (item
->line
>= line_num
)
4641 CORE_ADDR start
, end
;
4644 find_pc_partial_function (item
->pc
, &func_name
, &start
, &end
);
4646 if (func_name
!= NULL
&& item
->pc
< end
)
4648 if (item
->line
== line_num
)
4650 struct symbol
*sym
=
4651 standard_lookup (func_name
, VAR_DOMAIN
);
4652 if (is_plausible_func_for_line (sym
, starting_line
))
4656 while ((i
+ 1) < len
&& linetable
->item
[i
+ 1].pc
< end
)
4668 /* True iff function symbol SYM starts somewhere at or before line #
4671 is_plausible_func_for_line (struct symbol
*sym
, int line_num
)
4673 struct symtab_and_line start_sal
;
4678 start_sal
= find_function_start_sal (sym
, 0);
4680 return (start_sal
.line
!= 0 && line_num
>= start_sal
.line
);
4684 debug_print_lines (struct linetable
*lt
)
4691 fprintf (stderr
, "\t");
4692 for (i
= 0; i
< lt
->nitems
; i
+= 1)
4693 fprintf (stderr
, "(%d->%p) ", lt
->item
[i
].line
, (void *) lt
->item
[i
].pc
);
4694 fprintf (stderr
, "\n");
4698 debug_print_block (struct block
*b
)
4703 fprintf (stderr
, "Block: %p; [0x%lx, 0x%lx]",
4704 b
, BLOCK_START (b
), BLOCK_END (b
));
4705 if (BLOCK_FUNCTION (b
) != NULL
)
4706 fprintf (stderr
, " Function: %s", DEPRECATED_SYMBOL_NAME (BLOCK_FUNCTION (b
)));
4707 fprintf (stderr
, "\n");
4708 fprintf (stderr
, "\t Superblock: %p\n", BLOCK_SUPERBLOCK (b
));
4709 fprintf (stderr
, "\t Symbols:");
4710 ALL_BLOCK_SYMBOLS (b
, i
, sym
)
4712 if (i
> 0 && i
% 4 == 0)
4713 fprintf (stderr
, "\n\t\t ");
4714 fprintf (stderr
, " %s", DEPRECATED_SYMBOL_NAME (sym
));
4716 fprintf (stderr
, "\n");
4720 debug_print_blocks (struct blockvector
*bv
)
4726 for (i
= 0; i
< BLOCKVECTOR_NBLOCKS (bv
); i
+= 1)
4728 fprintf (stderr
, "%6d. ", i
);
4729 debug_print_block (BLOCKVECTOR_BLOCK (bv
, i
));
4734 debug_print_symtab (struct symtab
*s
)
4736 fprintf (stderr
, "Symtab %p\n File: %s; Dir: %s\n", s
,
4737 s
->filename
, s
->dirname
);
4738 fprintf (stderr
, " Blockvector: %p, Primary: %d\n",
4739 BLOCKVECTOR (s
), s
->primary
);
4740 debug_print_blocks (BLOCKVECTOR (s
));
4741 fprintf (stderr
, " Line table: %p\n", LINETABLE (s
));
4742 debug_print_lines (LINETABLE (s
));
4745 /* Read in all symbol tables corresponding to partial symbol tables
4746 with file name FILENAME. */
4748 read_all_symtabs (const char *filename
)
4750 struct partial_symtab
*ps
;
4751 struct objfile
*objfile
;
4753 ALL_PSYMTABS (objfile
, ps
)
4757 if (STREQ (filename
, ps
->filename
))
4758 PSYMTAB_TO_SYMTAB (ps
);
4762 /* All sals corresponding to line LINE_NUM in a symbol table from file
4763 FILENAME, as filtered by the user. If CANONICAL is not null, set
4764 it to a corresponding array of canonical line specs. */
4765 static struct symtabs_and_lines
4766 all_sals_for_line (const char *filename
, int line_num
, char ***canonical
)
4768 struct symtabs_and_lines result
;
4769 struct objfile
*objfile
;
4771 struct cleanup
*old_chain
= make_cleanup (null_cleanup
, NULL
);
4774 read_all_symtabs (filename
);
4777 (struct symtab_and_line
*) xmalloc (4 * sizeof (result
.sals
[0]));
4780 make_cleanup (free_current_contents
, &result
.sals
);
4782 ALL_SYMTABS (objfile
, s
)
4784 int ind
, target_line_num
;
4788 if (!STREQ (s
->filename
, filename
))
4792 nearest_line_number_in_linetable (LINETABLE (s
), line_num
);
4793 if (target_line_num
== -1)
4800 find_next_line_in_linetable (LINETABLE (s
),
4801 target_line_num
, line_num
, ind
);
4806 GROW_VECT (result
.sals
, len
, result
.nelts
+ 1);
4807 init_sal (&result
.sals
[result
.nelts
]);
4808 result
.sals
[result
.nelts
].line
= LINETABLE (s
)->item
[ind
].line
;
4809 result
.sals
[result
.nelts
].pc
= LINETABLE (s
)->item
[ind
].pc
;
4810 result
.sals
[result
.nelts
].symtab
= s
;
4815 if (canonical
!= NULL
|| result
.nelts
> 1)
4818 char **func_names
= (char **) alloca (result
.nelts
* sizeof (char *));
4819 int first_choice
= (result
.nelts
> 1) ? 2 : 1;
4821 int *choices
= (int *) alloca (result
.nelts
* sizeof (int));
4823 for (k
= 0; k
< result
.nelts
; k
+= 1)
4825 find_pc_partial_function (result
.sals
[k
].pc
, &func_names
[k
],
4826 (CORE_ADDR
*) NULL
, (CORE_ADDR
*) NULL
);
4827 if (func_names
[k
] == NULL
)
4828 error ("Could not find function for one or more breakpoints.");
4831 if (result
.nelts
> 1)
4833 printf_unfiltered ("[0] cancel\n");
4834 if (result
.nelts
> 1)
4835 printf_unfiltered ("[1] all\n");
4836 for (k
= 0; k
< result
.nelts
; k
+= 1)
4837 printf_unfiltered ("[%d] %s\n", k
+ first_choice
,
4838 ada_demangle (func_names
[k
]));
4840 n
= get_selections (choices
, result
.nelts
, result
.nelts
,
4841 result
.nelts
> 1, "instance-choice");
4843 for (k
= 0; k
< n
; k
+= 1)
4845 result
.sals
[k
] = result
.sals
[choices
[k
]];
4846 func_names
[k
] = func_names
[choices
[k
]];
4851 if (canonical
!= NULL
)
4853 *canonical
= (char **) xmalloc (result
.nelts
* sizeof (char **));
4854 make_cleanup (xfree
, *canonical
);
4855 for (k
= 0; k
< result
.nelts
; k
+= 1)
4858 extended_canonical_line_spec (result
.sals
[k
], func_names
[k
]);
4859 if ((*canonical
)[k
] == NULL
)
4860 error ("Could not locate one or more breakpoints.");
4861 make_cleanup (xfree
, (*canonical
)[k
]);
4866 discard_cleanups (old_chain
);
4871 /* A canonical line specification of the form FILE:NAME:LINENUM for
4872 symbol table and line data SAL. NULL if insufficient
4873 information. The caller is responsible for releasing any space
4877 extended_canonical_line_spec (struct symtab_and_line sal
, const char *name
)
4881 if (sal
.symtab
== NULL
|| sal
.symtab
->filename
== NULL
|| sal
.line
<= 0)
4884 r
= (char *) xmalloc (strlen (name
) + strlen (sal
.symtab
->filename
)
4885 + sizeof (sal
.line
) * 3 + 3);
4886 sprintf (r
, "%s:'%s':%d", sal
.symtab
->filename
, name
, sal
.line
);
4891 int begin_bnum
= -1;
4893 int begin_annotate_level
= 0;
4896 begin_cleanup (void *dummy
)
4898 begin_annotate_level
= 0;
4902 begin_command (char *args
, int from_tty
)
4904 struct minimal_symbol
*msym
;
4905 CORE_ADDR main_program_name_addr
;
4906 char main_program_name
[1024];
4907 struct cleanup
*old_chain
= make_cleanup (begin_cleanup
, NULL
);
4908 begin_annotate_level
= 2;
4910 /* Check that there is a program to debug */
4911 if (!have_full_symbols () && !have_partial_symbols ())
4912 error ("No symbol table is loaded. Use the \"file\" command.");
4914 /* Check that we are debugging an Ada program */
4915 /* if (ada_update_initial_language (language_unknown, NULL) != language_ada)
4916 error ("Cannot find the Ada initialization procedure. Is this an Ada main program?");
4918 /* FIXME: language_ada should be defined in defs.h */
4920 /* Get the address of the name of the main procedure */
4921 msym
= lookup_minimal_symbol (ADA_MAIN_PROGRAM_SYMBOL_NAME
, NULL
, NULL
);
4925 main_program_name_addr
= SYMBOL_VALUE_ADDRESS (msym
);
4926 if (main_program_name_addr
== 0)
4927 error ("Invalid address for Ada main program name.");
4929 /* Read the name of the main procedure */
4930 extract_string (main_program_name_addr
, main_program_name
);
4932 /* Put a temporary breakpoint in the Ada main program and run */
4933 do_command ("tbreak ", main_program_name
, 0);
4934 do_command ("run ", args
, 0);
4938 /* If we could not find the symbol containing the name of the
4939 main program, that means that the compiler that was used to build
4940 was not recent enough. In that case, we fallback to the previous
4941 mechanism, which is a little bit less reliable, but has proved to work
4942 in most cases. The only cases where it will fail is when the user
4943 has set some breakpoints which will be hit before the end of the
4944 begin command processing (eg in the initialization code).
4946 The begining of the main Ada subprogram is located by breaking
4947 on the adainit procedure. Since we know that the binder generates
4948 the call to this procedure exactly 2 calls before the call to the
4949 Ada main subprogram, it is then easy to put a breakpoint on this
4950 Ada main subprogram once we hit adainit.
4952 do_command ("tbreak adainit", 0);
4953 do_command ("run ", args
, 0);
4954 do_command ("up", 0);
4955 do_command ("tbreak +2", 0);
4956 do_command ("continue", 0);
4957 do_command ("step", 0);
4960 do_cleanups (old_chain
);
4964 is_ada_runtime_file (char *filename
)
4966 return (STREQN (filename
, "s-", 2) ||
4967 STREQN (filename
, "a-", 2) ||
4968 STREQN (filename
, "g-", 2) || STREQN (filename
, "i-", 2));
4971 /* find the first frame that contains debugging information and that is not
4972 part of the Ada run-time, starting from fi and moving upward. */
4975 find_printable_frame (struct frame_info
*fi
, int level
)
4977 struct symtab_and_line sal
;
4979 for (; fi
!= NULL
; level
+= 1, fi
= get_prev_frame (fi
))
4981 find_frame_sal (fi
, &sal
);
4982 if (sal
.symtab
&& !is_ada_runtime_file (sal
.symtab
->filename
))
4984 #if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
4985 /* libpthread.so contains some debugging information that prevents us
4986 from finding the right frame */
4988 if (sal
.symtab
->objfile
&&
4989 STREQ (sal
.symtab
->objfile
->name
, "/usr/shlib/libpthread.so"))
4992 deprecated_selected_frame
= fi
;
5001 ada_report_exception_break (struct breakpoint
*b
)
5003 /* FIXME: break_on_exception should be defined in breakpoint.h */
5004 /* if (b->break_on_exception == 1)
5006 /* Assume that cond has 16 elements, the 15th
5007 being the exception *//*
5008 if (b->cond && b->cond->nelts == 16)
5010 ui_out_text (uiout, "on ");
5011 ui_out_field_string (uiout, "exception",
5012 SYMBOL_NAME (b->cond->elts[14].symbol));
5015 ui_out_text (uiout, "on all exceptions");
5017 else if (b->break_on_exception == 2)
5018 ui_out_text (uiout, "on unhandled exception");
5019 else if (b->break_on_exception == 3)
5020 ui_out_text (uiout, "on assert failure");
5022 if (b->break_on_exception == 1)
5024 /* Assume that cond has 16 elements, the 15th
5025 being the exception *//*
5026 if (b->cond && b->cond->nelts == 16)
5028 fputs_filtered ("on ", gdb_stdout);
5029 fputs_filtered (SYMBOL_NAME
5030 (b->cond->elts[14].symbol), gdb_stdout);
5033 fputs_filtered ("on all exceptions", gdb_stdout);
5035 else if (b->break_on_exception == 2)
5036 fputs_filtered ("on unhandled exception", gdb_stdout);
5037 else if (b->break_on_exception == 3)
5038 fputs_filtered ("on assert failure", gdb_stdout);
5043 ada_is_exception_sym (struct symbol
*sym
)
5045 char *type_name
= type_name_no_tag (SYMBOL_TYPE (sym
));
5047 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5048 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5049 && SYMBOL_CLASS (sym
) != LOC_CONST
5050 && type_name
!= NULL
&& STREQ (type_name
, "exception"));
5054 ada_maybe_exception_partial_symbol (struct partial_symbol
*sym
)
5056 return (SYMBOL_CLASS (sym
) != LOC_TYPEDEF
5057 && SYMBOL_CLASS (sym
) != LOC_BLOCK
5058 && SYMBOL_CLASS (sym
) != LOC_CONST
);
5061 /* If ARG points to an Ada exception or assert breakpoint, rewrite
5062 into equivalent form. Return resulting argument string. Set
5063 *BREAK_ON_EXCEPTIONP to 1 for ordinary break on exception, 2 for
5064 break on unhandled, 3 for assert, 0 otherwise. */
5066 ada_breakpoint_rewrite (char *arg
, int *break_on_exceptionp
)
5070 *break_on_exceptionp
= 0;
5071 /* FIXME: language_ada should be defined in defs.h */
5072 /* if (current_language->la_language == language_ada
5073 && STREQN (arg, "exception", 9) &&
5074 (arg[9] == ' ' || arg[9] == '\t' || arg[9] == '\0'))
5076 char *tok, *end_tok;
5079 *break_on_exceptionp = 1;
5082 while (*tok == ' ' || *tok == '\t')
5087 while (*end_tok != ' ' && *end_tok != '\t' && *end_tok != '\000')
5090 toklen = end_tok - tok;
5092 arg = (char*) xmalloc (sizeof ("__gnat_raise_nodefer_with_msg if "
5093 "long_integer(e) = long_integer(&)")
5095 make_cleanup (xfree, arg);
5097 strcpy (arg, "__gnat_raise_nodefer_with_msg");
5098 else if (STREQN (tok, "unhandled", toklen))
5100 *break_on_exceptionp = 2;
5101 strcpy (arg, "__gnat_unhandled_exception");
5105 sprintf (arg, "__gnat_raise_nodefer_with_msg if "
5106 "long_integer(e) = long_integer(&%.*s)",
5110 else if (current_language->la_language == language_ada
5111 && STREQN (arg, "assert", 6) &&
5112 (arg[6] == ' ' || arg[6] == '\t' || arg[6] == '\0'))
5114 char *tok = arg + 6;
5116 *break_on_exceptionp = 3;
5119 xmalloc (sizeof ("system__assertions__raise_assert_failure")
5120 + strlen (tok) + 1);
5121 make_cleanup (xfree, arg);
5122 sprintf (arg, "system__assertions__raise_assert_failure%s", tok);
5131 /* True if field number FIELD_NUM in struct or union type TYPE is supposed
5132 to be invisible to users. */
5135 ada_is_ignored_field (struct type
*type
, int field_num
)
5137 if (field_num
< 0 || field_num
> TYPE_NFIELDS (type
))
5141 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5142 return (name
== NULL
5143 || (name
[0] == '_' && !STREQN (name
, "_parent", 7)));
5147 /* True iff structure type TYPE has a tag field. */
5150 ada_is_tagged_type (struct type
*type
)
5152 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5155 return (ada_lookup_struct_elt_type (type
, "_tag", 1, NULL
) != NULL
);
5158 /* The type of the tag on VAL. */
5161 ada_tag_type (struct value
*val
)
5163 return ada_lookup_struct_elt_type (VALUE_TYPE (val
), "_tag", 0, NULL
);
5166 /* The value of the tag on VAL. */
5169 ada_value_tag (struct value
*val
)
5171 return ada_value_struct_elt (val
, "_tag", "record");
5174 /* The parent type of TYPE, or NULL if none. */
5177 ada_parent_type (struct type
*type
)
5181 CHECK_TYPEDEF (type
);
5183 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
)
5186 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5187 if (ada_is_parent_field (type
, i
))
5188 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5193 /* True iff field number FIELD_NUM of structure type TYPE contains the
5194 parent-type (inherited) fields of a derived type. Assumes TYPE is
5195 a structure type with at least FIELD_NUM+1 fields. */
5198 ada_is_parent_field (struct type
*type
, int field_num
)
5200 const char *name
= TYPE_FIELD_NAME (check_typedef (type
), field_num
);
5201 return (name
!= NULL
&&
5202 (STREQN (name
, "PARENT", 6) || STREQN (name
, "_parent", 7)));
5205 /* True iff field number FIELD_NUM of structure type TYPE is a
5206 transparent wrapper field (which should be silently traversed when doing
5207 field selection and flattened when printing). Assumes TYPE is a
5208 structure type with at least FIELD_NUM+1 fields. Such fields are always
5212 ada_is_wrapper_field (struct type
*type
, int field_num
)
5214 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5215 return (name
!= NULL
5216 && (STREQN (name
, "PARENT", 6) || STREQ (name
, "REP")
5217 || STREQN (name
, "_parent", 7)
5218 || name
[0] == 'S' || name
[0] == 'R' || name
[0] == 'O'));
5221 /* True iff field number FIELD_NUM of structure or union type TYPE
5222 is a variant wrapper. Assumes TYPE is a structure type with at least
5223 FIELD_NUM+1 fields. */
5226 ada_is_variant_part (struct type
*type
, int field_num
)
5228 struct type
*field_type
= TYPE_FIELD_TYPE (type
, field_num
);
5229 return (TYPE_CODE (field_type
) == TYPE_CODE_UNION
5230 || (is_dynamic_field (type
, field_num
)
5231 && TYPE_CODE (TYPE_TARGET_TYPE (field_type
)) ==
5235 /* Assuming that VAR_TYPE is a variant wrapper (type of the variant part)
5236 whose discriminants are contained in the record type OUTER_TYPE,
5237 returns the type of the controlling discriminant for the variant. */
5240 ada_variant_discrim_type (struct type
*var_type
, struct type
*outer_type
)
5242 char *name
= ada_variant_discrim_name (var_type
);
5243 struct type
*type
= ada_lookup_struct_elt_type (outer_type
, name
, 1, NULL
);
5245 return builtin_type_int
;
5250 /* Assuming that TYPE is the type of a variant wrapper, and FIELD_NUM is a
5251 valid field number within it, returns 1 iff field FIELD_NUM of TYPE
5252 represents a 'when others' clause; otherwise 0. */
5255 ada_is_others_clause (struct type
*type
, int field_num
)
5257 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5258 return (name
!= NULL
&& name
[0] == 'O');
5261 /* Assuming that TYPE0 is the type of the variant part of a record,
5262 returns the name of the discriminant controlling the variant. The
5263 value is valid until the next call to ada_variant_discrim_name. */
5266 ada_variant_discrim_name (struct type
*type0
)
5268 static char *result
= NULL
;
5269 static size_t result_len
= 0;
5272 const char *discrim_end
;
5273 const char *discrim_start
;
5275 if (TYPE_CODE (type0
) == TYPE_CODE_PTR
)
5276 type
= TYPE_TARGET_TYPE (type0
);
5280 name
= ada_type_name (type
);
5282 if (name
== NULL
|| name
[0] == '\000')
5285 for (discrim_end
= name
+ strlen (name
) - 6; discrim_end
!= name
;
5288 if (STREQN (discrim_end
, "___XVN", 6))
5291 if (discrim_end
== name
)
5294 for (discrim_start
= discrim_end
; discrim_start
!= name
+ 3;
5297 if (discrim_start
== name
+ 1)
5299 if ((discrim_start
> name
+ 3 && STREQN (discrim_start
- 3, "___", 3))
5300 || discrim_start
[-1] == '.')
5304 GROW_VECT (result
, result_len
, discrim_end
- discrim_start
+ 1);
5305 strncpy (result
, discrim_start
, discrim_end
- discrim_start
);
5306 result
[discrim_end
- discrim_start
] = '\0';
5310 /* Scan STR for a subtype-encoded number, beginning at position K. Put the
5311 position of the character just past the number scanned in *NEW_K,
5312 if NEW_K!=NULL. Put the scanned number in *R, if R!=NULL. Return 1
5313 if there was a valid number at the given position, and 0 otherwise. A
5314 "subtype-encoded" number consists of the absolute value in decimal,
5315 followed by the letter 'm' to indicate a negative number. Assumes 0m
5319 ada_scan_number (const char str
[], int k
, LONGEST
* R
, int *new_k
)
5323 if (!isdigit (str
[k
]))
5326 /* Do it the hard way so as not to make any assumption about
5327 the relationship of unsigned long (%lu scan format code) and
5330 while (isdigit (str
[k
]))
5332 RU
= RU
* 10 + (str
[k
] - '0');
5339 *R
= (-(LONGEST
) (RU
- 1)) - 1;
5345 /* NOTE on the above: Technically, C does not say what the results of
5346 - (LONGEST) RU or (LONGEST) -RU are for RU == largest positive
5347 number representable as a LONGEST (although either would probably work
5348 in most implementations). When RU>0, the locution in the then branch
5349 above is always equivalent to the negative of RU. */
5356 /* Assuming that TYPE is a variant part wrapper type (a VARIANTS field),
5357 and FIELD_NUM is a valid field number within it, returns 1 iff VAL is
5358 in the range encoded by field FIELD_NUM of TYPE; otherwise 0. */
5361 ada_in_variant (LONGEST val
, struct type
*type
, int field_num
)
5363 const char *name
= TYPE_FIELD_NAME (type
, field_num
);
5376 if (!ada_scan_number (name
, p
+ 1, &W
, &p
))
5385 if (!ada_scan_number (name
, p
+ 1, &L
, &p
)
5386 || name
[p
] != 'T' || !ada_scan_number (name
, p
+ 1, &U
, &p
))
5388 if (val
>= L
&& val
<= U
)
5400 /* Given a value ARG1 (offset by OFFSET bytes)
5401 of a struct or union type ARG_TYPE,
5402 extract and return the value of one of its (non-static) fields.
5403 FIELDNO says which field. Differs from value_primitive_field only
5404 in that it can handle packed values of arbitrary type. */
5407 ada_value_primitive_field (struct value
*arg1
, int offset
, int fieldno
,
5408 struct type
*arg_type
)
5413 CHECK_TYPEDEF (arg_type
);
5414 type
= TYPE_FIELD_TYPE (arg_type
, fieldno
);
5416 /* Handle packed fields */
5418 if (TYPE_FIELD_BITSIZE (arg_type
, fieldno
) != 0)
5420 int bit_pos
= TYPE_FIELD_BITPOS (arg_type
, fieldno
);
5421 int bit_size
= TYPE_FIELD_BITSIZE (arg_type
, fieldno
);
5423 return ada_value_primitive_packed_val (arg1
, VALUE_CONTENTS (arg1
),
5424 offset
+ bit_pos
/ 8,
5425 bit_pos
% 8, bit_size
, type
);
5428 return value_primitive_field (arg1
, offset
, fieldno
, arg_type
);
5432 /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes,
5433 and search in it assuming it has (class) type TYPE.
5434 If found, return value, else return NULL.
5436 Searches recursively through wrapper fields (e.g., '_parent'). */
5439 ada_search_struct_field (char *name
, struct value
*arg
, int offset
,
5443 CHECK_TYPEDEF (type
);
5445 for (i
= TYPE_NFIELDS (type
) - 1; i
>= 0; i
-= 1)
5447 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5449 if (t_field_name
== NULL
)
5452 else if (field_name_match (t_field_name
, name
))
5453 return ada_value_primitive_field (arg
, offset
, i
, type
);
5455 else if (ada_is_wrapper_field (type
, i
))
5457 struct value
*v
= ada_search_struct_field (name
, arg
,
5459 TYPE_FIELD_BITPOS (type
,
5462 TYPE_FIELD_TYPE (type
,
5468 else if (ada_is_variant_part (type
, i
))
5471 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5472 int var_offset
= offset
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5474 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5476 struct value
*v
= ada_search_struct_field (name
, arg
,
5480 (field_type
, j
) / 8,
5491 /* Given ARG, a value of type (pointer to a)* structure/union,
5492 extract the component named NAME from the ultimate target structure/union
5493 and return it as a value with its appropriate type.
5495 The routine searches for NAME among all members of the structure itself
5496 and (recursively) among all members of any wrapper members
5499 ERR is a name (for use in error messages) that identifies the class
5500 of entity that ARG is supposed to be. */
5503 ada_value_struct_elt (struct value
*arg
, char *name
, char *err
)
5508 arg
= ada_coerce_ref (arg
);
5509 t
= check_typedef (VALUE_TYPE (arg
));
5511 /* Follow pointers until we get to a non-pointer. */
5513 while (TYPE_CODE (t
) == TYPE_CODE_PTR
|| TYPE_CODE (t
) == TYPE_CODE_REF
)
5515 arg
= ada_value_ind (arg
);
5516 t
= check_typedef (VALUE_TYPE (arg
));
5519 if (TYPE_CODE (t
) != TYPE_CODE_STRUCT
&& TYPE_CODE (t
) != TYPE_CODE_UNION
)
5520 error ("Attempt to extract a component of a value that is not a %s.",
5523 v
= ada_search_struct_field (name
, arg
, 0, t
);
5525 error ("There is no member named %s.", name
);
5530 /* Given a type TYPE, look up the type of the component of type named NAME.
5531 If DISPP is non-null, add its byte displacement from the beginning of a
5532 structure (pointed to by a value) of type TYPE to *DISPP (does not
5533 work for packed fields).
5535 Matches any field whose name has NAME as a prefix, possibly
5538 TYPE can be either a struct or union, or a pointer or reference to
5539 a struct or union. If it is a pointer or reference, its target
5540 type is automatically used.
5542 Looks recursively into variant clauses and parent types.
5544 If NOERR is nonzero, return NULL if NAME is not suitably defined. */
5547 ada_lookup_struct_elt_type (struct type
*type
, char *name
, int noerr
,
5557 CHECK_TYPEDEF (type
);
5558 if (TYPE_CODE (type
) != TYPE_CODE_PTR
5559 && TYPE_CODE (type
) != TYPE_CODE_REF
)
5561 type
= TYPE_TARGET_TYPE (type
);
5564 if (TYPE_CODE (type
) != TYPE_CODE_STRUCT
&&
5565 TYPE_CODE (type
) != TYPE_CODE_UNION
)
5567 target_terminal_ours ();
5568 gdb_flush (gdb_stdout
);
5569 fprintf_unfiltered (gdb_stderr
, "Type ");
5570 type_print (type
, "", gdb_stderr
, -1);
5571 error (" is not a structure or union type");
5574 type
= to_static_fixed_type (type
);
5576 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
5578 char *t_field_name
= TYPE_FIELD_NAME (type
, i
);
5582 if (t_field_name
== NULL
)
5585 else if (field_name_match (t_field_name
, name
))
5588 *dispp
+= TYPE_FIELD_BITPOS (type
, i
) / 8;
5589 return check_typedef (TYPE_FIELD_TYPE (type
, i
));
5592 else if (ada_is_wrapper_field (type
, i
))
5595 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (type
, i
), name
,
5600 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5605 else if (ada_is_variant_part (type
, i
))
5608 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, i
));
5610 for (j
= TYPE_NFIELDS (field_type
) - 1; j
>= 0; j
-= 1)
5613 t
= ada_lookup_struct_elt_type (TYPE_FIELD_TYPE (field_type
, j
),
5618 *dispp
+= disp
+ TYPE_FIELD_BITPOS (type
, i
) / 8;
5629 target_terminal_ours ();
5630 gdb_flush (gdb_stdout
);
5631 fprintf_unfiltered (gdb_stderr
, "Type ");
5632 type_print (type
, "", gdb_stderr
, -1);
5633 fprintf_unfiltered (gdb_stderr
, " has no component named ");
5634 error ("%s", name
== NULL
? "<null>" : name
);
5640 /* Assuming that VAR_TYPE is the type of a variant part of a record (a union),
5641 within a value of type OUTER_TYPE that is stored in GDB at
5642 OUTER_VALADDR, determine which variant clause (field number in VAR_TYPE,
5643 numbering from 0) is applicable. Returns -1 if none are. */
5646 ada_which_variant_applies (struct type
*var_type
, struct type
*outer_type
,
5647 char *outer_valaddr
)
5652 struct type
*discrim_type
;
5653 char *discrim_name
= ada_variant_discrim_name (var_type
);
5654 LONGEST discrim_val
;
5658 ada_lookup_struct_elt_type (outer_type
, discrim_name
, 1, &disp
);
5659 if (discrim_type
== NULL
)
5661 discrim_val
= unpack_long (discrim_type
, outer_valaddr
+ disp
);
5664 for (i
= 0; i
< TYPE_NFIELDS (var_type
); i
+= 1)
5666 if (ada_is_others_clause (var_type
, i
))
5668 else if (ada_in_variant (discrim_val
, var_type
, i
))
5672 return others_clause
;
5677 /* Dynamic-Sized Records */
5679 /* Strategy: The type ostensibly attached to a value with dynamic size
5680 (i.e., a size that is not statically recorded in the debugging
5681 data) does not accurately reflect the size or layout of the value.
5682 Our strategy is to convert these values to values with accurate,
5683 conventional types that are constructed on the fly. */
5685 /* There is a subtle and tricky problem here. In general, we cannot
5686 determine the size of dynamic records without its data. However,
5687 the 'struct value' data structure, which GDB uses to represent
5688 quantities in the inferior process (the target), requires the size
5689 of the type at the time of its allocation in order to reserve space
5690 for GDB's internal copy of the data. That's why the
5691 'to_fixed_xxx_type' routines take (target) addresses as parameters,
5692 rather than struct value*s.
5694 However, GDB's internal history variables ($1, $2, etc.) are
5695 struct value*s containing internal copies of the data that are not, in
5696 general, the same as the data at their corresponding addresses in
5697 the target. Fortunately, the types we give to these values are all
5698 conventional, fixed-size types (as per the strategy described
5699 above), so that we don't usually have to perform the
5700 'to_fixed_xxx_type' conversions to look at their values.
5701 Unfortunately, there is one exception: if one of the internal
5702 history variables is an array whose elements are unconstrained
5703 records, then we will need to create distinct fixed types for each
5704 element selected. */
5706 /* The upshot of all of this is that many routines take a (type, host
5707 address, target address) triple as arguments to represent a value.
5708 The host address, if non-null, is supposed to contain an internal
5709 copy of the relevant data; otherwise, the program is to consult the
5710 target at the target address. */
5712 /* Assuming that VAL0 represents a pointer value, the result of
5713 dereferencing it. Differs from value_ind in its treatment of
5714 dynamic-sized types. */
5717 ada_value_ind (struct value
*val0
)
5719 struct value
*val
= unwrap_value (value_ind (val0
));
5720 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5721 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
), val
);
5724 /* The value resulting from dereferencing any "reference to"
5725 * qualifiers on VAL0. */
5726 static struct value
*
5727 ada_coerce_ref (struct value
*val0
)
5729 if (TYPE_CODE (VALUE_TYPE (val0
)) == TYPE_CODE_REF
)
5731 struct value
*val
= val0
;
5733 val
= unwrap_value (val
);
5734 return ada_to_fixed_value (VALUE_TYPE (val
), 0,
5735 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
5742 /* Return OFF rounded upward if necessary to a multiple of
5743 ALIGNMENT (a power of 2). */
5746 align_value (unsigned int off
, unsigned int alignment
)
5748 return (off
+ alignment
- 1) & ~(alignment
- 1);
5751 /* Return the additional bit offset required by field F of template
5755 field_offset (struct type
*type
, int f
)
5757 int n
= TYPE_FIELD_BITPOS (type
, f
);
5758 /* Kludge (temporary?) to fix problem with dwarf output. */
5760 return (unsigned int) n
& 0xffff;
5766 /* Return the bit alignment required for field #F of template type TYPE. */
5769 field_alignment (struct type
*type
, int f
)
5771 const char *name
= TYPE_FIELD_NAME (type
, f
);
5772 int len
= (name
== NULL
) ? 0 : strlen (name
);
5775 if (len
< 8 || !isdigit (name
[len
- 1]))
5776 return TARGET_CHAR_BIT
;
5778 if (isdigit (name
[len
- 2]))
5779 align_offset
= len
- 2;
5781 align_offset
= len
- 1;
5783 if (align_offset
< 7 || !STREQN ("___XV", name
+ align_offset
- 6, 5))
5784 return TARGET_CHAR_BIT
;
5786 return atoi (name
+ align_offset
) * TARGET_CHAR_BIT
;
5789 /* Find a type named NAME. Ignores ambiguity. */
5791 ada_find_any_type (const char *name
)
5795 sym
= standard_lookup (name
, VAR_DOMAIN
);
5796 if (sym
!= NULL
&& SYMBOL_CLASS (sym
) == LOC_TYPEDEF
)
5797 return SYMBOL_TYPE (sym
);
5799 sym
= standard_lookup (name
, STRUCT_DOMAIN
);
5801 return SYMBOL_TYPE (sym
);
5806 /* Because of GNAT encoding conventions, several GDB symbols may match a
5807 given type name. If the type denoted by TYPE0 is to be preferred to
5808 that of TYPE1 for purposes of type printing, return non-zero;
5809 otherwise return 0. */
5811 ada_prefer_type (struct type
*type0
, struct type
*type1
)
5815 else if (type0
== NULL
)
5817 else if (TYPE_CODE (type1
) == TYPE_CODE_VOID
)
5819 else if (TYPE_CODE (type0
) == TYPE_CODE_VOID
)
5821 else if (ada_is_packed_array_type (type0
))
5823 else if (ada_is_array_descriptor (type0
)
5824 && !ada_is_array_descriptor (type1
))
5826 else if (ada_renaming_type (type0
) != NULL
5827 && ada_renaming_type (type1
) == NULL
)
5832 /* The name of TYPE, which is either its TYPE_NAME, or, if that is
5833 null, its TYPE_TAG_NAME. Null if TYPE is null. */
5835 ada_type_name (struct type
*type
)
5839 else if (TYPE_NAME (type
) != NULL
)
5840 return TYPE_NAME (type
);
5842 return TYPE_TAG_NAME (type
);
5845 /* Find a parallel type to TYPE whose name is formed by appending
5846 SUFFIX to the name of TYPE. */
5849 ada_find_parallel_type (struct type
*type
, const char *suffix
)
5852 static size_t name_len
= 0;
5853 struct symbol
**syms
;
5854 struct block
**blocks
;
5857 char *typename
= ada_type_name (type
);
5859 if (typename
== NULL
)
5862 len
= strlen (typename
);
5864 GROW_VECT (name
, name_len
, len
+ strlen (suffix
) + 1);
5866 strcpy (name
, typename
);
5867 strcpy (name
+ len
, suffix
);
5869 return ada_find_any_type (name
);
5873 /* If TYPE is a variable-size record type, return the corresponding template
5874 type describing its fields. Otherwise, return NULL. */
5876 static struct type
*
5877 dynamic_template_type (struct type
*type
)
5879 CHECK_TYPEDEF (type
);
5881 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5882 || ada_type_name (type
) == NULL
)
5886 int len
= strlen (ada_type_name (type
));
5887 if (len
> 6 && STREQ (ada_type_name (type
) + len
- 6, "___XVE"))
5890 return ada_find_parallel_type (type
, "___XVE");
5894 /* Assuming that TEMPL_TYPE is a union or struct type, returns
5895 non-zero iff field FIELD_NUM of TEMPL_TYPE has dynamic size. */
5898 is_dynamic_field (struct type
*templ_type
, int field_num
)
5900 const char *name
= TYPE_FIELD_NAME (templ_type
, field_num
);
5902 && TYPE_CODE (TYPE_FIELD_TYPE (templ_type
, field_num
)) == TYPE_CODE_PTR
5903 && strstr (name
, "___XVL") != NULL
;
5906 /* Assuming that TYPE is a struct type, returns non-zero iff TYPE
5907 contains a variant part. */
5910 contains_variant_part (struct type
*type
)
5914 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_STRUCT
5915 || TYPE_NFIELDS (type
) <= 0)
5917 return ada_is_variant_part (type
, TYPE_NFIELDS (type
) - 1);
5920 /* A record type with no fields, . */
5921 static struct type
*
5922 empty_record (struct objfile
*objfile
)
5924 struct type
*type
= alloc_type (objfile
);
5925 TYPE_CODE (type
) = TYPE_CODE_STRUCT
;
5926 TYPE_NFIELDS (type
) = 0;
5927 TYPE_FIELDS (type
) = NULL
;
5928 TYPE_NAME (type
) = "<empty>";
5929 TYPE_TAG_NAME (type
) = NULL
;
5930 TYPE_FLAGS (type
) = 0;
5931 TYPE_LENGTH (type
) = 0;
5935 /* An ordinary record type (with fixed-length fields) that describes
5936 the value of type TYPE at VALADDR or ADDRESS (see comments at
5937 the beginning of this section) VAL according to GNAT conventions.
5938 DVAL0 should describe the (portion of a) record that contains any
5939 necessary discriminants. It should be NULL if VALUE_TYPE (VAL) is
5940 an outer-level type (i.e., as opposed to a branch of a variant.) A
5941 variant field (unless unchecked) is replaced by a particular branch
5943 /* NOTE: Limitations: For now, we assume that dynamic fields and
5944 * variants occupy whole numbers of bytes. However, they need not be
5947 static struct type
*
5948 template_to_fixed_record_type (struct type
*type
, char *valaddr
,
5949 CORE_ADDR address
, struct value
*dval0
)
5951 struct value
*mark
= value_mark ();
5954 int nfields
, bit_len
;
5958 nfields
= TYPE_NFIELDS (type
);
5959 rtype
= alloc_type (TYPE_OBJFILE (type
));
5960 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
5961 INIT_CPLUS_SPECIFIC (rtype
);
5962 TYPE_NFIELDS (rtype
) = nfields
;
5963 TYPE_FIELDS (rtype
) = (struct field
*)
5964 TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
5965 memset (TYPE_FIELDS (rtype
), 0, sizeof (struct field
) * nfields
);
5966 TYPE_NAME (rtype
) = ada_type_name (type
);
5967 TYPE_TAG_NAME (rtype
) = NULL
;
5968 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in
5970 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
5974 for (f
= 0; f
< nfields
; f
+= 1)
5976 int fld_bit_len
, bit_incr
;
5979 field_alignment (type
, f
)) + TYPE_FIELD_BITPOS (type
, f
);
5980 /* NOTE: used to use field_offset above, but that causes
5981 * problems with really negative bit positions. So, let's
5982 * rediscover why we needed field_offset and fix it properly. */
5983 TYPE_FIELD_BITPOS (rtype
, f
) = off
;
5984 TYPE_FIELD_BITSIZE (rtype
, f
) = 0;
5985 TYPE_FIELD_STATIC_KIND (rtype
, f
) = 0;
5987 if (ada_is_variant_part (type
, f
))
5989 struct type
*branch_type
;
5992 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
5997 to_fixed_variant_branch_type
5998 (TYPE_FIELD_TYPE (type
, f
),
5999 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6000 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6001 if (branch_type
== NULL
)
6002 TYPE_NFIELDS (rtype
) -= 1;
6005 TYPE_FIELD_TYPE (rtype
, f
) = branch_type
;
6006 TYPE_FIELD_NAME (rtype
, f
) = "S";
6010 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6012 else if (is_dynamic_field (type
, f
))
6015 dval
= value_from_contents_and_address (rtype
, valaddr
, address
);
6019 TYPE_FIELD_TYPE (rtype
, f
) =
6022 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type
, f
))),
6023 cond_offset_host (valaddr
, off
/ TARGET_CHAR_BIT
),
6024 cond_offset_target (address
, off
/ TARGET_CHAR_BIT
), dval
);
6025 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6026 bit_incr
= fld_bit_len
=
6027 TYPE_LENGTH (TYPE_FIELD_TYPE (rtype
, f
)) * TARGET_CHAR_BIT
;
6031 TYPE_FIELD_TYPE (rtype
, f
) = TYPE_FIELD_TYPE (type
, f
);
6032 TYPE_FIELD_NAME (rtype
, f
) = TYPE_FIELD_NAME (type
, f
);
6033 if (TYPE_FIELD_BITSIZE (type
, f
) > 0)
6034 bit_incr
= fld_bit_len
=
6035 TYPE_FIELD_BITSIZE (rtype
, f
) = TYPE_FIELD_BITSIZE (type
, f
);
6037 bit_incr
= fld_bit_len
=
6038 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, f
)) * TARGET_CHAR_BIT
;
6040 if (off
+ fld_bit_len
> bit_len
)
6041 bit_len
= off
+ fld_bit_len
;
6043 TYPE_LENGTH (rtype
) = bit_len
/ TARGET_CHAR_BIT
;
6045 TYPE_LENGTH (rtype
) = align_value (TYPE_LENGTH (rtype
), TYPE_LENGTH (type
));
6047 value_free_to_mark (mark
);
6048 if (TYPE_LENGTH (rtype
) > varsize_limit
)
6049 error ("record type with dynamic size is larger than varsize-limit");
6053 /* As for template_to_fixed_record_type, but uses no run-time values.
6054 As a result, this type can only be approximate, but that's OK,
6055 since it is used only for type determinations. Works on both
6057 Representation note: to save space, we memoize the result of this
6058 function in the TYPE_TARGET_TYPE of the template type. */
6060 static struct type
*
6061 template_to_static_fixed_type (struct type
*templ_type
)
6067 if (TYPE_TARGET_TYPE (templ_type
) != NULL
)
6068 return TYPE_TARGET_TYPE (templ_type
);
6070 nfields
= TYPE_NFIELDS (templ_type
);
6071 TYPE_TARGET_TYPE (templ_type
) = type
=
6072 alloc_type (TYPE_OBJFILE (templ_type
));
6073 TYPE_CODE (type
) = TYPE_CODE (templ_type
);
6074 INIT_CPLUS_SPECIFIC (type
);
6075 TYPE_NFIELDS (type
) = nfields
;
6076 TYPE_FIELDS (type
) = (struct field
*)
6077 TYPE_ALLOC (type
, nfields
* sizeof (struct field
));
6078 memset (TYPE_FIELDS (type
), 0, sizeof (struct field
) * nfields
);
6079 TYPE_NAME (type
) = ada_type_name (templ_type
);
6080 TYPE_TAG_NAME (type
) = NULL
;
6081 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6082 /* TYPE_FLAGS (type) |= TYPE_FLAG_FIXED_INSTANCE; */
6083 TYPE_LENGTH (type
) = 0;
6085 for (f
= 0; f
< nfields
; f
+= 1)
6087 TYPE_FIELD_BITPOS (type
, f
) = 0;
6088 TYPE_FIELD_BITSIZE (type
, f
) = 0;
6089 TYPE_FIELD_STATIC_KIND (type
, f
) = 0;
6091 if (is_dynamic_field (templ_type
, f
))
6093 TYPE_FIELD_TYPE (type
, f
) =
6094 to_static_fixed_type (TYPE_TARGET_TYPE
6095 (TYPE_FIELD_TYPE (templ_type
, f
)));
6096 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6100 TYPE_FIELD_TYPE (type
, f
) =
6101 check_typedef (TYPE_FIELD_TYPE (templ_type
, f
));
6102 TYPE_FIELD_NAME (type
, f
) = TYPE_FIELD_NAME (templ_type
, f
);
6109 /* A revision of TYPE0 -- a non-dynamic-sized record with a variant
6110 part -- in which the variant part is replaced with the appropriate
6112 static struct type
*
6113 to_record_with_fixed_variant_part (struct type
*type
, char *valaddr
,
6114 CORE_ADDR address
, struct value
*dval
)
6116 struct value
*mark
= value_mark ();
6118 struct type
*branch_type
;
6119 int nfields
= TYPE_NFIELDS (type
);
6124 rtype
= alloc_type (TYPE_OBJFILE (type
));
6125 TYPE_CODE (rtype
) = TYPE_CODE_STRUCT
;
6126 INIT_CPLUS_SPECIFIC (type
);
6127 TYPE_NFIELDS (rtype
) = TYPE_NFIELDS (type
);
6128 TYPE_FIELDS (rtype
) =
6129 (struct field
*) TYPE_ALLOC (rtype
, nfields
* sizeof (struct field
));
6130 memcpy (TYPE_FIELDS (rtype
), TYPE_FIELDS (type
),
6131 sizeof (struct field
) * nfields
);
6132 TYPE_NAME (rtype
) = ada_type_name (type
);
6133 TYPE_TAG_NAME (rtype
) = NULL
;
6134 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6135 /* TYPE_FLAGS (rtype) |= TYPE_FLAG_FIXED_INSTANCE; */
6136 TYPE_LENGTH (rtype
) = TYPE_LENGTH (type
);
6139 to_fixed_variant_branch_type
6140 (TYPE_FIELD_TYPE (type
, nfields
- 1),
6141 cond_offset_host (valaddr
,
6142 TYPE_FIELD_BITPOS (type
,
6143 nfields
- 1) / TARGET_CHAR_BIT
),
6144 cond_offset_target (address
,
6145 TYPE_FIELD_BITPOS (type
,
6146 nfields
- 1) / TARGET_CHAR_BIT
),
6148 if (branch_type
== NULL
)
6150 TYPE_NFIELDS (rtype
) -= 1;
6151 TYPE_LENGTH (rtype
) -=
6152 TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6156 TYPE_FIELD_TYPE (rtype
, nfields
- 1) = branch_type
;
6157 TYPE_FIELD_NAME (rtype
, nfields
- 1) = "S";
6158 TYPE_FIELD_BITSIZE (rtype
, nfields
- 1) = 0;
6159 TYPE_FIELD_STATIC_KIND (rtype
, nfields
- 1) = 0;
6160 TYPE_LENGTH (rtype
) += TYPE_LENGTH (branch_type
);
6161 -TYPE_LENGTH (TYPE_FIELD_TYPE (type
, nfields
- 1));
6167 /* An ordinary record type (with fixed-length fields) that describes
6168 the value at (TYPE0, VALADDR, ADDRESS) [see explanation at
6169 beginning of this section]. Any necessary discriminants' values
6170 should be in DVAL, a record value; it should be NULL if the object
6171 at ADDR itself contains any necessary discriminant values. A
6172 variant field (unless unchecked) is replaced by a particular branch
6175 static struct type
*
6176 to_fixed_record_type (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6179 struct type
*templ_type
;
6181 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6182 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6185 templ_type
= dynamic_template_type (type0
);
6187 if (templ_type
!= NULL
)
6188 return template_to_fixed_record_type (templ_type
, valaddr
, address
, dval
);
6189 else if (contains_variant_part (type0
))
6190 return to_record_with_fixed_variant_part (type0
, valaddr
, address
, dval
);
6193 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6194 /* TYPE_FLAGS (type0) |= TYPE_FLAG_FIXED_INSTANCE; */
6200 /* An ordinary record type (with fixed-length fields) that describes
6201 the value at (VAR_TYPE0, VALADDR, ADDRESS), where VAR_TYPE0 is a
6202 union type. Any necessary discriminants' values should be in DVAL,
6203 a record value. That is, this routine selects the appropriate
6204 branch of the union at ADDR according to the discriminant value
6205 indicated in the union's type name. */
6207 static struct type
*
6208 to_fixed_variant_branch_type (struct type
*var_type0
, char *valaddr
,
6209 CORE_ADDR address
, struct value
*dval
)
6212 struct type
*templ_type
;
6213 struct type
*var_type
;
6215 if (TYPE_CODE (var_type0
) == TYPE_CODE_PTR
)
6216 var_type
= TYPE_TARGET_TYPE (var_type0
);
6218 var_type
= var_type0
;
6220 templ_type
= ada_find_parallel_type (var_type
, "___XVU");
6222 if (templ_type
!= NULL
)
6223 var_type
= templ_type
;
6226 ada_which_variant_applies (var_type
,
6227 VALUE_TYPE (dval
), VALUE_CONTENTS (dval
));
6230 return empty_record (TYPE_OBJFILE (var_type
));
6231 else if (is_dynamic_field (var_type
, which
))
6233 to_fixed_record_type
6234 (TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (var_type
, which
)),
6235 valaddr
, address
, dval
);
6236 else if (contains_variant_part (TYPE_FIELD_TYPE (var_type
, which
)))
6238 to_fixed_record_type
6239 (TYPE_FIELD_TYPE (var_type
, which
), valaddr
, address
, dval
);
6241 return TYPE_FIELD_TYPE (var_type
, which
);
6244 /* Assuming that TYPE0 is an array type describing the type of a value
6245 at ADDR, and that DVAL describes a record containing any
6246 discriminants used in TYPE0, returns a type for the value that
6247 contains no dynamic components (that is, no components whose sizes
6248 are determined by run-time quantities). Unless IGNORE_TOO_BIG is
6249 true, gives an error message if the resulting type's size is over
6253 static struct type
*
6254 to_fixed_array_type (struct type
*type0
, struct value
*dval
,
6257 struct type
*index_type_desc
;
6258 struct type
*result
;
6260 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6261 /* if (ada_is_packed_array_type (type0) /* revisit? *//*
6262 || (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE))
6265 index_type_desc
= ada_find_parallel_type (type0
, "___XA");
6266 if (index_type_desc
== NULL
)
6268 struct type
*elt_type0
= check_typedef (TYPE_TARGET_TYPE (type0
));
6269 /* NOTE: elt_type---the fixed version of elt_type0---should never
6270 * depend on the contents of the array in properly constructed
6271 * debugging data. */
6272 struct type
*elt_type
= ada_to_fixed_type (elt_type0
, 0, 0, dval
);
6274 if (elt_type0
== elt_type
)
6277 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6278 elt_type
, TYPE_INDEX_TYPE (type0
));
6283 struct type
*elt_type0
;
6286 for (i
= TYPE_NFIELDS (index_type_desc
); i
> 0; i
-= 1)
6287 elt_type0
= TYPE_TARGET_TYPE (elt_type0
);
6289 /* NOTE: result---the fixed version of elt_type0---should never
6290 * depend on the contents of the array in properly constructed
6291 * debugging data. */
6292 result
= ada_to_fixed_type (check_typedef (elt_type0
), 0, 0, dval
);
6293 for (i
= TYPE_NFIELDS (index_type_desc
) - 1; i
>= 0; i
-= 1)
6295 struct type
*range_type
=
6296 to_fixed_range_type (TYPE_FIELD_NAME (index_type_desc
, i
),
6297 dval
, TYPE_OBJFILE (type0
));
6298 result
= create_array_type (alloc_type (TYPE_OBJFILE (type0
)),
6299 result
, range_type
);
6301 if (!ignore_too_big
&& TYPE_LENGTH (result
) > varsize_limit
)
6302 error ("array type with dynamic size is larger than varsize-limit");
6305 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6306 /* TYPE_FLAGS (result) |= TYPE_FLAG_FIXED_INSTANCE; */
6311 /* A standard type (containing no dynamically sized components)
6312 corresponding to TYPE for the value (TYPE, VALADDR, ADDRESS)
6313 DVAL describes a record containing any discriminants used in TYPE0,
6314 and may be NULL if there are none. */
6317 ada_to_fixed_type (struct type
*type
, char *valaddr
, CORE_ADDR address
,
6320 CHECK_TYPEDEF (type
);
6321 switch (TYPE_CODE (type
))
6325 case TYPE_CODE_STRUCT
:
6326 return to_fixed_record_type (type
, valaddr
, address
, NULL
);
6327 case TYPE_CODE_ARRAY
:
6328 return to_fixed_array_type (type
, dval
, 0);
6329 case TYPE_CODE_UNION
:
6333 return to_fixed_variant_branch_type (type
, valaddr
, address
, dval
);
6337 /* A standard (static-sized) type corresponding as well as possible to
6338 TYPE0, but based on no runtime data. */
6340 static struct type
*
6341 to_static_fixed_type (struct type
*type0
)
6348 /* FIXME: TYPE_FLAG_FIXED_INSTANCE should be defined in gdbtypes.h */
6349 /* if (TYPE_FLAGS (type0) & TYPE_FLAG_FIXED_INSTANCE)
6352 CHECK_TYPEDEF (type0
);
6354 switch (TYPE_CODE (type0
))
6358 case TYPE_CODE_STRUCT
:
6359 type
= dynamic_template_type (type0
);
6361 return template_to_static_fixed_type (type
);
6363 case TYPE_CODE_UNION
:
6364 type
= ada_find_parallel_type (type0
, "___XVU");
6366 return template_to_static_fixed_type (type
);
6371 /* A static approximation of TYPE with all type wrappers removed. */
6372 static struct type
*
6373 static_unwrap_type (struct type
*type
)
6375 if (ada_is_aligner_type (type
))
6377 struct type
*type1
= TYPE_FIELD_TYPE (check_typedef (type
), 0);
6378 if (ada_type_name (type1
) == NULL
)
6379 TYPE_NAME (type1
) = ada_type_name (type
);
6381 return static_unwrap_type (type1
);
6385 struct type
*raw_real_type
= ada_get_base_type (type
);
6386 if (raw_real_type
== type
)
6389 return to_static_fixed_type (raw_real_type
);
6393 /* In some cases, incomplete and private types require
6394 cross-references that are not resolved as records (for example,
6396 type FooP is access Foo;
6398 type Foo is array ...;
6399 ). In these cases, since there is no mechanism for producing
6400 cross-references to such types, we instead substitute for FooP a
6401 stub enumeration type that is nowhere resolved, and whose tag is
6402 the name of the actual type. Call these types "non-record stubs". */
6404 /* A type equivalent to TYPE that is not a non-record stub, if one
6405 exists, otherwise TYPE. */
6407 ada_completed_type (struct type
*type
)
6409 CHECK_TYPEDEF (type
);
6410 if (type
== NULL
|| TYPE_CODE (type
) != TYPE_CODE_ENUM
6411 || (TYPE_FLAGS (type
) & TYPE_FLAG_STUB
) == 0
6412 || TYPE_TAG_NAME (type
) == NULL
)
6416 char *name
= TYPE_TAG_NAME (type
);
6417 struct type
*type1
= ada_find_any_type (name
);
6418 return (type1
== NULL
) ? type
: type1
;
6422 /* A value representing the data at VALADDR/ADDRESS as described by
6423 type TYPE0, but with a standard (static-sized) type that correctly
6424 describes it. If VAL0 is not NULL and TYPE0 already is a standard
6425 type, then return VAL0 [this feature is simply to avoid redundant
6426 creation of struct values]. */
6429 ada_to_fixed_value (struct type
*type0
, char *valaddr
, CORE_ADDR address
,
6432 struct type
*type
= ada_to_fixed_type (type0
, valaddr
, address
, NULL
);
6433 if (type
== type0
&& val0
!= NULL
)
6436 return value_from_contents_and_address (type
, valaddr
, address
);
6439 /* A value representing VAL, but with a standard (static-sized) type
6440 chosen to approximate the real type of VAL as well as possible, but
6441 without consulting any runtime values. For Ada dynamic-sized
6442 types, therefore, the type of the result is likely to be inaccurate. */
6445 ada_to_static_fixed_value (struct value
*val
)
6448 to_static_fixed_type (static_unwrap_type (VALUE_TYPE (val
)));
6449 if (type
== VALUE_TYPE (val
))
6452 return coerce_unspec_val_to_type (val
, 0, type
);
6461 /* Table mapping attribute numbers to names */
6462 /* NOTE: Keep up to date with enum ada_attribute definition in ada-lang.h */
6464 static const char *attribute_names
[] = {
6481 ada_attribute_name (int n
)
6483 if (n
> 0 && n
< (int) ATR_END
)
6484 return attribute_names
[n
];
6486 return attribute_names
[0];
6489 /* Evaluate the 'POS attribute applied to ARG. */
6491 static struct value
*
6492 value_pos_atr (struct value
*arg
)
6494 struct type
*type
= VALUE_TYPE (arg
);
6496 if (!discrete_type_p (type
))
6497 error ("'POS only defined on discrete types");
6499 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6502 LONGEST v
= value_as_long (arg
);
6504 for (i
= 0; i
< TYPE_NFIELDS (type
); i
+= 1)
6506 if (v
== TYPE_FIELD_BITPOS (type
, i
))
6507 return value_from_longest (builtin_type_ada_int
, i
);
6509 error ("enumeration value is invalid: can't find 'POS");
6512 return value_from_longest (builtin_type_ada_int
, value_as_long (arg
));
6515 /* Evaluate the TYPE'VAL attribute applied to ARG. */
6517 static struct value
*
6518 value_val_atr (struct type
*type
, struct value
*arg
)
6520 if (!discrete_type_p (type
))
6521 error ("'VAL only defined on discrete types");
6522 if (!integer_type_p (VALUE_TYPE (arg
)))
6523 error ("'VAL requires integral argument");
6525 if (TYPE_CODE (type
) == TYPE_CODE_ENUM
)
6527 long pos
= value_as_long (arg
);
6528 if (pos
< 0 || pos
>= TYPE_NFIELDS (type
))
6529 error ("argument to 'VAL out of range");
6530 return value_from_longest (type
, TYPE_FIELD_BITPOS (type
, pos
));
6533 return value_from_longest (type
, value_as_long (arg
));
6539 /* True if TYPE appears to be an Ada character type.
6540 * [At the moment, this is true only for Character and Wide_Character;
6541 * It is a heuristic test that could stand improvement]. */
6544 ada_is_character_type (struct type
*type
)
6546 const char *name
= ada_type_name (type
);
6549 && (TYPE_CODE (type
) == TYPE_CODE_CHAR
6550 || TYPE_CODE (type
) == TYPE_CODE_INT
6551 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
6552 && (STREQ (name
, "character") || STREQ (name
, "wide_character")
6553 || STREQ (name
, "unsigned char"));
6556 /* True if TYPE appears to be an Ada string type. */
6559 ada_is_string_type (struct type
*type
)
6561 CHECK_TYPEDEF (type
);
6563 && TYPE_CODE (type
) != TYPE_CODE_PTR
6564 && (ada_is_simple_array (type
) || ada_is_array_descriptor (type
))
6565 && ada_array_arity (type
) == 1)
6567 struct type
*elttype
= ada_array_element_type (type
, 1);
6569 return ada_is_character_type (elttype
);
6576 /* True if TYPE is a struct type introduced by the compiler to force the
6577 alignment of a value. Such types have a single field with a
6578 distinctive name. */
6581 ada_is_aligner_type (struct type
*type
)
6583 CHECK_TYPEDEF (type
);
6584 return (TYPE_CODE (type
) == TYPE_CODE_STRUCT
6585 && TYPE_NFIELDS (type
) == 1
6586 && STREQ (TYPE_FIELD_NAME (type
, 0), "F"));
6589 /* If there is an ___XVS-convention type parallel to SUBTYPE, return
6590 the parallel type. */
6593 ada_get_base_type (struct type
*raw_type
)
6595 struct type
*real_type_namer
;
6596 struct type
*raw_real_type
;
6597 struct type
*real_type
;
6599 if (raw_type
== NULL
|| TYPE_CODE (raw_type
) != TYPE_CODE_STRUCT
)
6602 real_type_namer
= ada_find_parallel_type (raw_type
, "___XVS");
6603 if (real_type_namer
== NULL
6604 || TYPE_CODE (real_type_namer
) != TYPE_CODE_STRUCT
6605 || TYPE_NFIELDS (real_type_namer
) != 1)
6608 raw_real_type
= ada_find_any_type (TYPE_FIELD_NAME (real_type_namer
, 0));
6609 if (raw_real_type
== NULL
)
6612 return raw_real_type
;
6615 /* The type of value designated by TYPE, with all aligners removed. */
6618 ada_aligned_type (struct type
*type
)
6620 if (ada_is_aligner_type (type
))
6621 return ada_aligned_type (TYPE_FIELD_TYPE (type
, 0));
6623 return ada_get_base_type (type
);
6627 /* The address of the aligned value in an object at address VALADDR
6628 having type TYPE. Assumes ada_is_aligner_type (TYPE). */
6631 ada_aligned_value_addr (struct type
*type
, char *valaddr
)
6633 if (ada_is_aligner_type (type
))
6634 return ada_aligned_value_addr (TYPE_FIELD_TYPE (type
, 0),
6636 TYPE_FIELD_BITPOS (type
,
6637 0) / TARGET_CHAR_BIT
);
6642 /* The printed representation of an enumeration literal with encoded
6643 name NAME. The value is good to the next call of ada_enum_name. */
6645 ada_enum_name (const char *name
)
6651 if ((tmp
= strstr (name
, "__")) != NULL
)
6653 else if ((tmp
= strchr (name
, '.')) != NULL
)
6661 static char result
[16];
6663 if (name
[1] == 'U' || name
[1] == 'W')
6665 if (sscanf (name
+ 2, "%x", &v
) != 1)
6671 if (isascii (v
) && isprint (v
))
6672 sprintf (result
, "'%c'", v
);
6673 else if (name
[1] == 'U')
6674 sprintf (result
, "[\"%02x\"]", v
);
6676 sprintf (result
, "[\"%04x\"]", v
);
6684 static struct value
*
6685 evaluate_subexp (struct type
*expect_type
, struct expression
*exp
, int *pos
,
6688 return (*exp
->language_defn
->evaluate_exp
) (expect_type
, exp
, pos
, noside
);
6691 /* Evaluate the subexpression of EXP starting at *POS as for
6692 evaluate_type, updating *POS to point just past the evaluated
6695 static struct value
*
6696 evaluate_subexp_type (struct expression
*exp
, int *pos
)
6698 return (*exp
->language_defn
->evaluate_exp
)
6699 (NULL_TYPE
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
6702 /* If VAL is wrapped in an aligner or subtype wrapper, return the
6705 static struct value
*
6706 unwrap_value (struct value
*val
)
6708 struct type
*type
= check_typedef (VALUE_TYPE (val
));
6709 if (ada_is_aligner_type (type
))
6711 struct value
*v
= value_struct_elt (&val
, NULL
, "F",
6712 NULL
, "internal structure");
6713 struct type
*val_type
= check_typedef (VALUE_TYPE (v
));
6714 if (ada_type_name (val_type
) == NULL
)
6715 TYPE_NAME (val_type
) = ada_type_name (type
);
6717 return unwrap_value (v
);
6721 struct type
*raw_real_type
=
6722 ada_completed_type (ada_get_base_type (type
));
6724 if (type
== raw_real_type
)
6728 coerce_unspec_val_to_type
6729 (val
, 0, ada_to_fixed_type (raw_real_type
, 0,
6730 VALUE_ADDRESS (val
) + VALUE_OFFSET (val
),
6735 static struct value
*
6736 cast_to_fixed (struct type
*type
, struct value
*arg
)
6740 if (type
== VALUE_TYPE (arg
))
6742 else if (ada_is_fixed_point_type (VALUE_TYPE (arg
)))
6743 val
= ada_float_to_fixed (type
,
6744 ada_fixed_to_float (VALUE_TYPE (arg
),
6745 value_as_long (arg
)));
6749 value_as_double (value_cast (builtin_type_double
, value_copy (arg
)));
6750 val
= ada_float_to_fixed (type
, argd
);
6753 return value_from_longest (type
, val
);
6756 static struct value
*
6757 cast_from_fixed_to_double (struct value
*arg
)
6759 DOUBLEST val
= ada_fixed_to_float (VALUE_TYPE (arg
),
6760 value_as_long (arg
));
6761 return value_from_double (builtin_type_double
, val
);
6764 /* Coerce VAL as necessary for assignment to an lval of type TYPE, and
6765 * return the converted value. */
6766 static struct value
*
6767 coerce_for_assign (struct type
*type
, struct value
*val
)
6769 struct type
*type2
= VALUE_TYPE (val
);
6773 CHECK_TYPEDEF (type2
);
6774 CHECK_TYPEDEF (type
);
6776 if (TYPE_CODE (type2
) == TYPE_CODE_PTR
6777 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6779 val
= ada_value_ind (val
);
6780 type2
= VALUE_TYPE (val
);
6783 if (TYPE_CODE (type2
) == TYPE_CODE_ARRAY
6784 && TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
6786 if (TYPE_LENGTH (type2
) != TYPE_LENGTH (type
)
6787 || TYPE_LENGTH (TYPE_TARGET_TYPE (type2
))
6788 != TYPE_LENGTH (TYPE_TARGET_TYPE (type2
)))
6789 error ("Incompatible types in assignment");
6790 VALUE_TYPE (val
) = type
;
6796 ada_evaluate_subexp (struct type
*expect_type
, struct expression
*exp
,
6797 int *pos
, enum noside noside
)
6800 enum ada_attribute atr
;
6801 int tem
, tem2
, tem3
;
6803 struct value
*arg1
= NULL
, *arg2
= NULL
, *arg3
;
6806 struct value
**argvec
;
6810 op
= exp
->elts
[pc
].opcode
;
6817 unwrap_value (evaluate_subexp_standard
6818 (expect_type
, exp
, pos
, noside
));
6822 type
= exp
->elts
[pc
+ 1].type
;
6823 arg1
= evaluate_subexp (type
, exp
, pos
, noside
);
6824 if (noside
== EVAL_SKIP
)
6826 if (type
!= check_typedef (VALUE_TYPE (arg1
)))
6828 if (ada_is_fixed_point_type (type
))
6829 arg1
= cast_to_fixed (type
, arg1
);
6830 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6831 arg1
= value_cast (type
, cast_from_fixed_to_double (arg1
));
6832 else if (VALUE_LVAL (arg1
) == lval_memory
)
6834 /* This is in case of the really obscure (and undocumented,
6835 but apparently expected) case of (Foo) Bar.all, where Bar
6836 is an integer constant and Foo is a dynamic-sized type.
6837 If we don't do this, ARG1 will simply be relabeled with
6839 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6840 return value_zero (to_static_fixed_type (type
), not_lval
);
6843 (type
, 0, VALUE_ADDRESS (arg1
) + VALUE_OFFSET (arg1
), 0);
6846 arg1
= value_cast (type
, arg1
);
6850 /* FIXME: UNOP_QUAL should be defined in expression.h */
6853 type = exp->elts[pc + 1].type;
6854 return ada_evaluate_subexp (type, exp, pos, noside);
6857 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6858 arg2
= evaluate_subexp (VALUE_TYPE (arg1
), exp
, pos
, noside
);
6859 if (noside
== EVAL_SKIP
|| noside
== EVAL_AVOID_SIDE_EFFECTS
)
6861 if (binop_user_defined_p (op
, arg1
, arg2
))
6862 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6865 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6866 arg2
= cast_to_fixed (VALUE_TYPE (arg1
), arg2
);
6867 else if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6869 ("Fixed-point values must be assigned to fixed-point variables");
6871 arg2
= coerce_for_assign (VALUE_TYPE (arg1
), arg2
);
6872 return ada_value_assign (arg1
, arg2
);
6876 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6877 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6878 if (noside
== EVAL_SKIP
)
6880 if (binop_user_defined_p (op
, arg1
, arg2
))
6881 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6884 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6885 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6886 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6888 ("Operands of fixed-point addition must have the same type");
6889 return value_cast (VALUE_TYPE (arg1
), value_add (arg1
, arg2
));
6893 arg1
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6894 arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
6895 if (noside
== EVAL_SKIP
)
6897 if (binop_user_defined_p (op
, arg1
, arg2
))
6898 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6901 if ((ada_is_fixed_point_type (VALUE_TYPE (arg1
))
6902 || ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6903 && VALUE_TYPE (arg1
) != VALUE_TYPE (arg2
))
6905 ("Operands of fixed-point subtraction must have the same type");
6906 return value_cast (VALUE_TYPE (arg1
), value_sub (arg1
, arg2
));
6911 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6912 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6913 if (noside
== EVAL_SKIP
)
6915 if (binop_user_defined_p (op
, arg1
, arg2
))
6916 return value_x_binop (arg1
, arg2
, op
, OP_NULL
, EVAL_NORMAL
);
6918 if (noside
== EVAL_AVOID_SIDE_EFFECTS
6919 && (op
== BINOP_DIV
|| op
== BINOP_REM
|| op
== BINOP_MOD
))
6920 return value_zero (VALUE_TYPE (arg1
), not_lval
);
6923 if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6924 arg1
= cast_from_fixed_to_double (arg1
);
6925 if (ada_is_fixed_point_type (VALUE_TYPE (arg2
)))
6926 arg2
= cast_from_fixed_to_double (arg2
);
6927 return value_binop (arg1
, arg2
, op
);
6931 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
6932 if (noside
== EVAL_SKIP
)
6934 if (unop_user_defined_p (op
, arg1
))
6935 return value_x_unop (arg1
, op
, EVAL_NORMAL
);
6936 else if (ada_is_fixed_point_type (VALUE_TYPE (arg1
)))
6937 return value_cast (VALUE_TYPE (arg1
), value_neg (arg1
));
6939 return value_neg (arg1
);
6941 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
6942 /* case OP_UNRESOLVED_VALUE:
6943 /* Only encountered when an unresolved symbol occurs in a
6944 context other than a function call, in which case, it is
6947 if (noside == EVAL_SKIP)
6950 error ("Unexpected unresolved symbol, %s, during evaluation",
6951 ada_demangle (exp->elts[pc + 2].name));
6955 if (noside
== EVAL_SKIP
)
6960 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
6964 (to_static_fixed_type
6965 (static_unwrap_type (SYMBOL_TYPE (exp
->elts
[pc
+ 2].symbol
))),
6971 unwrap_value (evaluate_subexp_standard
6972 (expect_type
, exp
, pos
, noside
));
6973 return ada_to_fixed_value (VALUE_TYPE (arg1
), 0,
6974 VALUE_ADDRESS (arg1
) +
6975 VALUE_OFFSET (arg1
), arg1
);
6980 tem2
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
6981 tem3
= longest_to_int (exp
->elts
[pc
+ 2].longconst
);
6982 nargs
= tem3
- tem2
+ 1;
6983 type
= expect_type
? check_typedef (expect_type
) : NULL_TYPE
;
6986 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 1));
6987 for (tem
= 0; tem
== 0 || tem
< nargs
; tem
+= 1)
6988 /* At least one element gets inserted for the type */
6990 /* Ensure that array expressions are coerced into pointer objects. */
6991 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
6993 if (noside
== EVAL_SKIP
)
6995 return value_array (tem2
, tem3
, argvec
);
7000 /* Allocate arg vector, including space for the function to be
7001 called in argvec[0] and a terminating NULL */
7002 nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7004 (struct value
* *) alloca (sizeof (struct value
*) * (nargs
+ 2));
7006 /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
7007 /* FIXME: name should be defined in expresion.h */
7008 /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
7009 error ("Unexpected unresolved symbol, %s, during evaluation",
7010 ada_demangle (exp->elts[pc + 5].name));
7014 error ("unexpected code path, FIXME");
7018 for (tem
= 0; tem
<= nargs
; tem
+= 1)
7019 argvec
[tem
] = evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7022 if (noside
== EVAL_SKIP
)
7026 if (TYPE_CODE (VALUE_TYPE (argvec
[0])) == TYPE_CODE_REF
)
7027 argvec
[0] = value_addr (argvec
[0]);
7029 if (ada_is_packed_array_type (VALUE_TYPE (argvec
[0])))
7030 argvec
[0] = ada_coerce_to_simple_array (argvec
[0]);
7032 type
= check_typedef (VALUE_TYPE (argvec
[0]));
7033 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
7035 switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type
))))
7037 case TYPE_CODE_FUNC
:
7038 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7040 case TYPE_CODE_ARRAY
:
7042 case TYPE_CODE_STRUCT
:
7043 if (noside
!= EVAL_AVOID_SIDE_EFFECTS
)
7044 argvec
[0] = ada_value_ind (argvec
[0]);
7045 type
= check_typedef (TYPE_TARGET_TYPE (type
));
7048 error ("cannot subscript or call something of type `%s'",
7049 ada_type_name (VALUE_TYPE (argvec
[0])));
7054 switch (TYPE_CODE (type
))
7056 case TYPE_CODE_FUNC
:
7057 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7058 return allocate_value (TYPE_TARGET_TYPE (type
));
7059 return call_function_by_hand (argvec
[0], nargs
, argvec
+ 1);
7060 case TYPE_CODE_STRUCT
:
7062 int arity
= ada_array_arity (type
);
7063 type
= ada_array_element_type (type
, nargs
);
7065 error ("cannot subscript or call a record");
7067 error ("wrong number of subscripts; expecting %d", arity
);
7068 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7069 return allocate_value (ada_aligned_type (type
));
7071 unwrap_value (ada_value_subscript
7072 (argvec
[0], nargs
, argvec
+ 1));
7074 case TYPE_CODE_ARRAY
:
7075 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7077 type
= ada_array_element_type (type
, nargs
);
7079 error ("element type of array unknown");
7081 return allocate_value (ada_aligned_type (type
));
7084 unwrap_value (ada_value_subscript
7085 (ada_coerce_to_simple_array (argvec
[0]),
7086 nargs
, argvec
+ 1));
7087 case TYPE_CODE_PTR
: /* Pointer to array */
7088 type
= to_fixed_array_type (TYPE_TARGET_TYPE (type
), NULL
, 1);
7089 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7091 type
= ada_array_element_type (type
, nargs
);
7093 error ("element type of array unknown");
7095 return allocate_value (ada_aligned_type (type
));
7098 unwrap_value (ada_value_ptr_subscript (argvec
[0], type
,
7099 nargs
, argvec
+ 1));
7102 error ("Internal error in evaluate_subexp");
7107 struct value
*array
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7109 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7111 = value_as_long (evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
));
7112 if (noside
== EVAL_SKIP
)
7115 /* If this is a reference to an array, then dereference it */
7116 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_REF
7117 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7118 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7120 && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7122 array
= ada_coerce_ref (array
);
7125 if (noside
== EVAL_AVOID_SIDE_EFFECTS
&&
7126 ada_is_array_descriptor (check_typedef (VALUE_TYPE (array
))))
7128 /* Try to dereference the array, in case it is an access to array */
7129 struct type
*arrType
= ada_type_of_array (array
, 0);
7130 if (arrType
!= NULL
)
7131 array
= value_at_lazy (arrType
, 0, NULL
);
7133 if (ada_is_array_descriptor (VALUE_TYPE (array
)))
7134 array
= ada_coerce_to_simple_array (array
);
7136 /* If at this point we have a pointer to an array, it means that
7137 it is a pointer to a simple (non-ada) array. We just then
7139 if (TYPE_CODE (VALUE_TYPE (array
)) == TYPE_CODE_PTR
7140 && TYPE_TARGET_TYPE (VALUE_TYPE (array
)) != NULL
7141 && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array
))) ==
7144 array
= ada_value_ind (array
);
7147 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7148 /* The following will get the bounds wrong, but only in contexts
7149 where the value is not being requested (FIXME?). */
7152 return value_slice (array
, lowbound
, upper
- lowbound
+ 1);
7155 /* FIXME: UNOP_MBR should be defined in expression.h */
7158 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7159 type = exp->elts[pc + 1].type;
7161 if (noside == EVAL_SKIP)
7164 switch (TYPE_CODE (type))
7167 warning ("Membership test incompletely implemented; always returns true");
7168 return value_from_longest (builtin_type_int, (LONGEST) 1);
7170 case TYPE_CODE_RANGE:
7171 arg2 = value_from_longest (builtin_type_int,
7172 (LONGEST) TYPE_LOW_BOUND (type));
7173 arg3 = value_from_longest (builtin_type_int,
7174 (LONGEST) TYPE_HIGH_BOUND (type));
7176 value_from_longest (builtin_type_int,
7177 (value_less (arg1,arg3)
7178 || value_equal (arg1,arg3))
7179 && (value_less (arg2,arg1)
7180 || value_equal (arg2,arg1)));
7183 /* FIXME: BINOP_MBR should be defined in expression.h */
7186 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7187 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7189 if (noside == EVAL_SKIP)
7192 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7193 return value_zero (builtin_type_int, not_lval);
7195 tem = longest_to_int (exp->elts[pc + 1].longconst);
7197 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
7198 error ("invalid dimension number to '%s", "range");
7200 arg3 = ada_array_bound (arg2, tem, 1);
7201 arg2 = ada_array_bound (arg2, tem, 0);
7204 value_from_longest (builtin_type_int,
7205 (value_less (arg1,arg3)
7206 || value_equal (arg1,arg3))
7207 && (value_less (arg2,arg1)
7208 || value_equal (arg2,arg1)));
7210 /* FIXME: TERNOP_MBR should be defined in expression.h */
7212 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7213 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7214 arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7216 if (noside == EVAL_SKIP)
7220 value_from_longest (builtin_type_int,
7221 (value_less (arg1,arg3)
7222 || value_equal (arg1,arg3))
7223 && (value_less (arg2,arg1)
7224 || value_equal (arg2,arg1)));
7226 /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
7227 /* case OP_ATTRIBUTE:
7229 atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
7233 error ("unexpected attribute encountered");
7239 struct type* type_arg;
7240 if (exp->elts[*pos].opcode == OP_TYPE)
7242 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7244 type_arg = exp->elts[pc + 5].type;
7248 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7252 if (exp->elts[*pos].opcode != OP_LONG)
7253 error ("illegal operand to '%s", ada_attribute_name (atr));
7254 tem = longest_to_int (exp->elts[*pos+2].longconst);
7257 if (noside == EVAL_SKIP)
7260 if (type_arg == NULL)
7262 arg1 = ada_coerce_ref (arg1);
7264 if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
7265 arg1 = ada_coerce_to_simple_array (arg1);
7267 if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
7268 error ("invalid dimension number to '%s",
7269 ada_attribute_name (atr));
7271 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7273 type = ada_index_type (VALUE_TYPE (arg1), tem);
7275 error ("attempt to take bound of something that is not an array");
7276 return allocate_value (type);
7282 error ("unexpected attribute encountered");
7284 return ada_array_bound (arg1, tem, 0);
7286 return ada_array_bound (arg1, tem, 1);
7288 return ada_array_length (arg1, tem);
7291 else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
7292 || TYPE_CODE (type_arg) == TYPE_CODE_INT)
7294 struct type* range_type;
7295 char* name = ada_type_name (type_arg);
7298 if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
7299 range_type = type_arg;
7301 error ("unimplemented type attribute");
7305 to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
7309 error ("unexpected attribute encountered");
7311 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7312 TYPE_LOW_BOUND (range_type));
7314 return value_from_longest (TYPE_TARGET_TYPE (range_type),
7315 TYPE_HIGH_BOUND (range_type));
7318 else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
7323 error ("unexpected attribute encountered");
7325 return value_from_longest
7326 (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
7328 return value_from_longest
7330 TYPE_FIELD_BITPOS (type_arg,
7331 TYPE_NFIELDS (type_arg) - 1));
7334 else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
7335 error ("unimplemented type attribute");
7340 if (ada_is_packed_array_type (type_arg))
7341 type_arg = decode_packed_array_type (type_arg);
7343 if (tem < 1 || tem > ada_array_arity (type_arg))
7344 error ("invalid dimension number to '%s",
7345 ada_attribute_name (atr));
7347 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7349 type = ada_index_type (type_arg, tem);
7351 error ("attempt to take bound of something that is not an array");
7352 return allocate_value (type);
7358 error ("unexpected attribute encountered");
7360 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7361 return value_from_longest (type, low);
7363 high = ada_array_bound_from_type (type_arg, tem, 1, &type);
7364 return value_from_longest (type, high);
7366 low = ada_array_bound_from_type (type_arg, tem, 0, &type);
7367 high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
7368 return value_from_longest (type, high-low+1);
7374 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7375 if (noside == EVAL_SKIP)
7378 if (noside == EVAL_AVOID_SIDE_EFFECTS)
7380 value_zero (ada_tag_type (arg1), not_lval);
7382 return ada_value_tag (arg1);
7386 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7387 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7388 arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7389 if (noside == EVAL_SKIP)
7391 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7392 return value_zero (VALUE_TYPE (arg1), not_lval);
7394 return value_binop (arg1, arg2,
7395 atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
7399 struct type* type_arg = exp->elts[pc + 5].type;
7400 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7403 if (noside == EVAL_SKIP)
7406 if (! ada_is_modular_type (type_arg))
7407 error ("'modulus must be applied to modular type");
7409 return value_from_longest (TYPE_TARGET_TYPE (type_arg),
7410 ada_modulus (type_arg));
7415 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7416 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7417 if (noside == EVAL_SKIP)
7419 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7420 return value_zero (builtin_type_ada_int, not_lval);
7422 return value_pos_atr (arg1);
7425 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7426 if (noside == EVAL_SKIP)
7428 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7429 return value_zero (builtin_type_ada_int, not_lval);
7431 return value_from_longest (builtin_type_ada_int,
7433 * TYPE_LENGTH (VALUE_TYPE (arg1)));
7436 evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
7437 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
7438 type = exp->elts[pc + 5].type;
7439 if (noside == EVAL_SKIP)
7441 else if (noside == EVAL_AVOID_SIDE_EFFECTS)
7442 return value_zero (type, not_lval);
7444 return value_val_atr (type, arg1);
7447 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7448 arg2
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7449 if (noside
== EVAL_SKIP
)
7451 if (binop_user_defined_p (op
, arg1
, arg2
))
7452 return unwrap_value (value_x_binop (arg1
, arg2
, op
, OP_NULL
,
7454 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7455 return value_zero (VALUE_TYPE (arg1
), not_lval
);
7457 return value_binop (arg1
, arg2
, op
);
7460 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7461 if (noside
== EVAL_SKIP
)
7463 if (unop_user_defined_p (op
, arg1
))
7464 return unwrap_value (value_x_unop (arg1
, op
, EVAL_NORMAL
));
7469 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7470 if (noside
== EVAL_SKIP
)
7472 if (value_less (arg1
, value_zero (VALUE_TYPE (arg1
), not_lval
)))
7473 return value_neg (arg1
);
7478 if (expect_type
&& TYPE_CODE (expect_type
) == TYPE_CODE_PTR
)
7479 expect_type
= TYPE_TARGET_TYPE (check_typedef (expect_type
));
7480 arg1
= evaluate_subexp (expect_type
, exp
, pos
, noside
);
7481 if (noside
== EVAL_SKIP
)
7483 type
= check_typedef (VALUE_TYPE (arg1
));
7484 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7486 if (ada_is_array_descriptor (type
))
7487 /* GDB allows dereferencing GNAT array descriptors. */
7489 struct type
*arrType
= ada_type_of_array (arg1
, 0);
7490 if (arrType
== NULL
)
7491 error ("Attempt to dereference null array pointer.");
7492 return value_at_lazy (arrType
, 0, NULL
);
7494 else if (TYPE_CODE (type
) == TYPE_CODE_PTR
7495 || TYPE_CODE (type
) == TYPE_CODE_REF
7496 /* In C you can dereference an array to get the 1st elt. */
7497 || TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
7500 (to_static_fixed_type
7501 (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type
)))),
7503 else if (TYPE_CODE (type
) == TYPE_CODE_INT
)
7504 /* GDB allows dereferencing an int. */
7505 return value_zero (builtin_type_int
, lval_memory
);
7507 error ("Attempt to take contents of a non-pointer value.");
7509 arg1
= ada_coerce_ref (arg1
);
7510 type
= check_typedef (VALUE_TYPE (arg1
));
7512 if (ada_is_array_descriptor (type
))
7513 /* GDB allows dereferencing GNAT array descriptors. */
7514 return ada_coerce_to_simple_array (arg1
);
7516 return ada_value_ind (arg1
);
7518 case STRUCTOP_STRUCT
:
7519 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7520 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7521 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7522 if (noside
== EVAL_SKIP
)
7524 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7525 return value_zero (ada_aligned_type
7526 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7532 return unwrap_value (ada_value_struct_elt (arg1
,
7533 &exp
->elts
[pc
+ 2].string
,
7536 /* The value is not supposed to be used. This is here to make it
7537 easier to accommodate expressions that contain types. */
7539 if (noside
== EVAL_SKIP
)
7541 else if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7542 return allocate_value (builtin_type_void
);
7544 error ("Attempt to use a type name as an expression");
7547 tem
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
7548 (*pos
) += 3 + BYTES_TO_EXP_ELEM (tem
+ 1);
7549 arg1
= evaluate_subexp (NULL_TYPE
, exp
, pos
, noside
);
7550 if (noside
== EVAL_SKIP
)
7552 if (noside
== EVAL_AVOID_SIDE_EFFECTS
)
7553 return value_zero (ada_aligned_type
7554 (ada_lookup_struct_elt_type (VALUE_TYPE (arg1
),
7560 return unwrap_value (ada_value_struct_elt (arg1
,
7561 &exp
->elts
[pc
+ 2].string
,
7566 return value_from_longest (builtin_type_long
, (LONGEST
) 1);
7572 /* If TYPE encodes an Ada fixed-point type, return the suffix of the
7573 type name that encodes the 'small and 'delta information.
7574 Otherwise, return NULL. */
7577 fixed_type_info (struct type
*type
)
7579 const char *name
= ada_type_name (type
);
7580 enum type_code code
= (type
== NULL
) ? TYPE_CODE_UNDEF
: TYPE_CODE (type
);
7582 if ((code
== TYPE_CODE_INT
|| code
== TYPE_CODE_RANGE
) && name
!= NULL
)
7584 const char *tail
= strstr (name
, "___XF_");
7590 else if (code
== TYPE_CODE_RANGE
&& TYPE_TARGET_TYPE (type
) != type
)
7591 return fixed_type_info (TYPE_TARGET_TYPE (type
));
7596 /* Returns non-zero iff TYPE represents an Ada fixed-point type. */
7599 ada_is_fixed_point_type (struct type
*type
)
7601 return fixed_type_info (type
) != NULL
;
7604 /* Assuming that TYPE is the representation of an Ada fixed-point
7605 type, return its delta, or -1 if the type is malformed and the
7606 delta cannot be determined. */
7609 ada_delta (struct type
*type
)
7611 const char *encoding
= fixed_type_info (type
);
7614 if (sscanf (encoding
, "_%ld_%ld", &num
, &den
) < 2)
7617 return (DOUBLEST
) num
/ (DOUBLEST
) den
;
7620 /* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
7621 factor ('SMALL value) associated with the type. */
7624 scaling_factor (struct type
*type
)
7626 const char *encoding
= fixed_type_info (type
);
7627 unsigned long num0
, den0
, num1
, den1
;
7630 n
= sscanf (encoding
, "_%lu_%lu_%lu_%lu", &num0
, &den0
, &num1
, &den1
);
7635 return (DOUBLEST
) num1
/ (DOUBLEST
) den1
;
7637 return (DOUBLEST
) num0
/ (DOUBLEST
) den0
;
7641 /* Assuming that X is the representation of a value of fixed-point
7642 type TYPE, return its floating-point equivalent. */
7645 ada_fixed_to_float (struct type
*type
, LONGEST x
)
7647 return (DOUBLEST
) x
*scaling_factor (type
);
7650 /* The representation of a fixed-point value of type TYPE
7651 corresponding to the value X. */
7654 ada_float_to_fixed (struct type
*type
, DOUBLEST x
)
7656 return (LONGEST
) (x
/ scaling_factor (type
) + 0.5);
7660 /* VAX floating formats */
7662 /* Non-zero iff TYPE represents one of the special VAX floating-point
7665 ada_is_vax_floating_type (struct type
*type
)
7668 (ada_type_name (type
) == NULL
) ? 0 : strlen (ada_type_name (type
));
7671 && (TYPE_CODE (type
) == TYPE_CODE_INT
7672 || TYPE_CODE (type
) == TYPE_CODE_RANGE
)
7673 && STREQN (ada_type_name (type
) + name_len
- 6, "___XF", 5);
7676 /* The type of special VAX floating-point type this is, assuming
7677 ada_is_vax_floating_point */
7679 ada_vax_float_type_suffix (struct type
*type
)
7681 return ada_type_name (type
)[strlen (ada_type_name (type
)) - 1];
7684 /* A value representing the special debugging function that outputs
7685 VAX floating-point values of the type represented by TYPE. Assumes
7686 ada_is_vax_floating_type (TYPE). */
7688 ada_vax_float_print_function (struct type
*type
)
7690 switch (ada_vax_float_type_suffix (type
))
7693 return get_var_value ("DEBUG_STRING_F", 0);
7695 return get_var_value ("DEBUG_STRING_D", 0);
7697 return get_var_value ("DEBUG_STRING_G", 0);
7699 error ("invalid VAX floating-point type");
7706 /* Scan STR beginning at position K for a discriminant name, and
7707 return the value of that discriminant field of DVAL in *PX. If
7708 PNEW_K is not null, put the position of the character beyond the
7709 name scanned in *PNEW_K. Return 1 if successful; return 0 and do
7710 not alter *PX and *PNEW_K if unsuccessful. */
7713 scan_discrim_bound (char *, int k
, struct value
*dval
, LONGEST
* px
,
7716 static char *bound_buffer
= NULL
;
7717 static size_t bound_buffer_len
= 0;
7720 struct value
*bound_val
;
7722 if (dval
== NULL
|| str
== NULL
|| str
[k
] == '\0')
7725 pend
= strstr (str
+ k
, "__");
7729 k
+= strlen (bound
);
7733 GROW_VECT (bound_buffer
, bound_buffer_len
, pend
- (str
+ k
) + 1);
7734 bound
= bound_buffer
;
7735 strncpy (bound_buffer
, str
+ k
, pend
- (str
+ k
));
7736 bound
[pend
- (str
+ k
)] = '\0';
7740 bound_val
= ada_search_struct_field (bound
, dval
, 0, VALUE_TYPE (dval
));
7741 if (bound_val
== NULL
)
7744 *px
= value_as_long (bound_val
);
7750 /* Value of variable named NAME in the current environment. If
7751 no such variable found, then if ERR_MSG is null, returns 0, and
7752 otherwise causes an error with message ERR_MSG. */
7753 static struct value
*
7754 get_var_value (char *name
, char *err_msg
)
7756 struct symbol
**syms
;
7757 struct block
**blocks
;
7761 ada_lookup_symbol_list (name
, get_selected_block (NULL
), VAR_DOMAIN
,
7766 if (err_msg
== NULL
)
7769 error ("%s", err_msg
);
7772 return value_of_variable (syms
[0], blocks
[0]);
7775 /* Value of integer variable named NAME in the current environment. If
7776 no such variable found, then if ERR_MSG is null, returns 0, and sets
7777 *FLAG to 0. If successful, sets *FLAG to 1. */
7779 get_int_var_value (char *name
, char *err_msg
, int *flag
)
7781 struct value
*var_val
= get_var_value (name
, err_msg
);
7793 return value_as_long (var_val
);
7798 /* Return a range type whose base type is that of the range type named
7799 NAME in the current environment, and whose bounds are calculated
7800 from NAME according to the GNAT range encoding conventions.
7801 Extract discriminant values, if needed, from DVAL. If a new type
7802 must be created, allocate in OBJFILE's space. The bounds
7803 information, in general, is encoded in NAME, the base type given in
7804 the named range type. */
7806 static struct type
*
7807 to_fixed_range_type (char *name
, struct value
*dval
, struct objfile
*objfile
)
7809 struct type
*raw_type
= ada_find_any_type (name
);
7810 struct type
*base_type
;
7814 if (raw_type
== NULL
)
7815 base_type
= builtin_type_int
;
7816 else if (TYPE_CODE (raw_type
) == TYPE_CODE_RANGE
)
7817 base_type
= TYPE_TARGET_TYPE (raw_type
);
7819 base_type
= raw_type
;
7821 subtype_info
= strstr (name
, "___XD");
7822 if (subtype_info
== NULL
)
7826 static char *name_buf
= NULL
;
7827 static size_t name_len
= 0;
7828 int prefix_len
= subtype_info
- name
;
7834 GROW_VECT (name_buf
, name_len
, prefix_len
+ 5);
7835 strncpy (name_buf
, name
, prefix_len
);
7836 name_buf
[prefix_len
] = '\0';
7839 bounds_str
= strchr (subtype_info
, '_');
7842 if (*subtype_info
== 'L')
7844 if (!ada_scan_number (bounds_str
, n
, &L
, &n
)
7845 && !scan_discrim_bound (bounds_str
, n
, dval
, &L
, &n
))
7847 if (bounds_str
[n
] == '_')
7849 else if (bounds_str
[n
] == '.') /* FIXME? SGI Workshop kludge. */
7855 strcpy (name_buf
+ prefix_len
, "___L");
7856 L
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7859 if (*subtype_info
== 'U')
7861 if (!ada_scan_number (bounds_str
, n
, &U
, &n
)
7862 && !scan_discrim_bound (bounds_str
, n
, dval
, &U
, &n
))
7867 strcpy (name_buf
+ prefix_len
, "___U");
7868 U
= get_int_var_value (name_buf
, "Index bound unknown.", NULL
);
7871 if (objfile
== NULL
)
7872 objfile
= TYPE_OBJFILE (base_type
);
7873 type
= create_range_type (alloc_type (objfile
), base_type
, L
, U
);
7874 TYPE_NAME (type
) = name
;
7879 /* True iff NAME is the name of a range type. */
7881 ada_is_range_type_name (const char *name
)
7883 return (name
!= NULL
&& strstr (name
, "___XD"));
7889 /* True iff TYPE is an Ada modular type. */
7891 ada_is_modular_type (struct type
*type
)
7893 /* FIXME: base_type should be declared in gdbtypes.h, implemented in
7895 struct type
*subranged_type
; /* = base_type (type); */
7897 return (subranged_type
!= NULL
&& TYPE_CODE (type
) == TYPE_CODE_RANGE
7898 && TYPE_CODE (subranged_type
) != TYPE_CODE_ENUM
7899 && TYPE_UNSIGNED (subranged_type
));
7902 /* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
7904 ada_modulus (struct type
* type
)
7906 return TYPE_HIGH_BOUND (type
) + 1;
7913 /* Table mapping opcodes into strings for printing operators
7914 and precedences of the operators. */
7916 static const struct op_print ada_op_print_tab
[] = {
7917 {":=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
7918 {"or else", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
7919 {"and then", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
7920 {"or", BINOP_BITWISE_IOR
, PREC_BITWISE_IOR
, 0},
7921 {"xor", BINOP_BITWISE_XOR
, PREC_BITWISE_XOR
, 0},
7922 {"and", BINOP_BITWISE_AND
, PREC_BITWISE_AND
, 0},
7923 {"=", BINOP_EQUAL
, PREC_EQUAL
, 0},
7924 {"/=", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
7925 {"<=", BINOP_LEQ
, PREC_ORDER
, 0},
7926 {">=", BINOP_GEQ
, PREC_ORDER
, 0},
7927 {">", BINOP_GTR
, PREC_ORDER
, 0},
7928 {"<", BINOP_LESS
, PREC_ORDER
, 0},
7929 {">>", BINOP_RSH
, PREC_SHIFT
, 0},
7930 {"<<", BINOP_LSH
, PREC_SHIFT
, 0},
7931 {"+", BINOP_ADD
, PREC_ADD
, 0},
7932 {"-", BINOP_SUB
, PREC_ADD
, 0},
7933 {"&", BINOP_CONCAT
, PREC_ADD
, 0},
7934 {"*", BINOP_MUL
, PREC_MUL
, 0},
7935 {"/", BINOP_DIV
, PREC_MUL
, 0},
7936 {"rem", BINOP_REM
, PREC_MUL
, 0},
7937 {"mod", BINOP_MOD
, PREC_MUL
, 0},
7938 {"**", BINOP_EXP
, PREC_REPEAT
, 0},
7939 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
7940 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
7941 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
7942 {"not ", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
7943 {"not ", UNOP_COMPLEMENT
, PREC_PREFIX
, 0},
7944 {"abs ", UNOP_ABS
, PREC_PREFIX
, 0},
7945 {".all", UNOP_IND
, PREC_SUFFIX
, 1}, /* FIXME: postfix .ALL */
7946 {"'access", UNOP_ADDR
, PREC_SUFFIX
, 1}, /* FIXME: postfix 'ACCESS */
7950 /* Assorted Types and Interfaces */
7952 struct type
*builtin_type_ada_int
;
7953 struct type
*builtin_type_ada_short
;
7954 struct type
*builtin_type_ada_long
;
7955 struct type
*builtin_type_ada_long_long
;
7956 struct type
*builtin_type_ada_char
;
7957 struct type
*builtin_type_ada_float
;
7958 struct type
*builtin_type_ada_double
;
7959 struct type
*builtin_type_ada_long_double
;
7960 struct type
*builtin_type_ada_natural
;
7961 struct type
*builtin_type_ada_positive
;
7962 struct type
*builtin_type_ada_system_address
;
7964 struct type
**const (ada_builtin_types
[]) =
7967 &builtin_type_ada_int
,
7968 &builtin_type_ada_long
,
7969 &builtin_type_ada_short
,
7970 &builtin_type_ada_char
,
7971 &builtin_type_ada_float
,
7972 &builtin_type_ada_double
,
7973 &builtin_type_ada_long_long
,
7974 &builtin_type_ada_long_double
,
7975 &builtin_type_ada_natural
, &builtin_type_ada_positive
,
7976 /* The following types are carried over from C for convenience. */
7979 &builtin_type_short
,
7981 &builtin_type_float
,
7982 &builtin_type_double
,
7983 &builtin_type_long_long
,
7985 &builtin_type_signed_char
,
7986 &builtin_type_unsigned_char
,
7987 &builtin_type_unsigned_short
,
7988 &builtin_type_unsigned_int
,
7989 &builtin_type_unsigned_long
,
7990 &builtin_type_unsigned_long_long
,
7991 &builtin_type_long_double
,
7992 &builtin_type_complex
, &builtin_type_double_complex
, 0};
7994 /* Not really used, but needed in the ada_language_defn. */
7996 emit_char (int c
, struct ui_file
*stream
, int quoter
)
7998 ada_emit_char (c
, stream
, quoter
, 1);
8001 const struct language_defn ada_language_defn
= {
8002 "ada", /* Language name */
8005 /* FIXME: language_ada should be defined in defs.h */
8009 case_sensitive_on
, /* Yes, Ada is case-insensitive, but
8010 * that's not quite what this means. */
8013 ada_evaluate_subexp
,
8014 ada_printchar
, /* Print a character constant */
8015 ada_printstr
, /* Function to print string constant */
8016 emit_char
, /* Function to print single char (not used) */
8017 ada_create_fundamental_type
, /* Create fundamental type in this language */
8018 ada_print_type
, /* Print a type using appropriate syntax */
8019 ada_val_print
, /* Print a value using appropriate syntax */
8020 ada_value_print
, /* Print a top-level value */
8021 NULL
, /* Language specific skip_trampoline */
8022 value_of_this
, /* value_of_this */
8023 basic_lookup_symbol_nonlocal
, /* lookup_symbol_nonlocal */
8024 NULL
, /* Language specific symbol demangler */
8025 {"", "", "", ""}, /* Binary format info */
8027 {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
8028 {"%ld", "", "d", ""}, /* Decimal format info */
8029 {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
8031 /* Copied from c-lang.c. */
8032 {"0%lo", "0", "o", ""}, /* Octal format info */
8033 {"%ld", "", "d", ""}, /* Decimal format info */
8034 {"0x%lx", "0x", "x", ""}, /* Hex format info */
8036 ada_op_print_tab
, /* expression operators for printing */
8037 1, /* c-style arrays (FIXME?) */
8038 0, /* String lower bound (FIXME?) */
8039 &builtin_type_ada_char
,
8044 _initialize_ada_language (void)
8046 builtin_type_ada_int
=
8047 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8048 0, "integer", (struct objfile
*) NULL
);
8049 builtin_type_ada_long
=
8050 init_type (TYPE_CODE_INT
, TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8051 0, "long_integer", (struct objfile
*) NULL
);
8052 builtin_type_ada_short
=
8053 init_type (TYPE_CODE_INT
, TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8054 0, "short_integer", (struct objfile
*) NULL
);
8055 builtin_type_ada_char
=
8056 init_type (TYPE_CODE_INT
, TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8057 0, "character", (struct objfile
*) NULL
);
8058 builtin_type_ada_float
=
8059 init_type (TYPE_CODE_FLT
, TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8060 0, "float", (struct objfile
*) NULL
);
8061 builtin_type_ada_double
=
8062 init_type (TYPE_CODE_FLT
, TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8063 0, "long_float", (struct objfile
*) NULL
);
8064 builtin_type_ada_long_long
=
8065 init_type (TYPE_CODE_INT
, TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8066 0, "long_long_integer", (struct objfile
*) NULL
);
8067 builtin_type_ada_long_double
=
8068 init_type (TYPE_CODE_FLT
, TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8069 0, "long_long_float", (struct objfile
*) NULL
);
8070 builtin_type_ada_natural
=
8071 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8072 0, "natural", (struct objfile
*) NULL
);
8073 builtin_type_ada_positive
=
8074 init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8075 0, "positive", (struct objfile
*) NULL
);
8078 builtin_type_ada_system_address
=
8079 lookup_pointer_type (init_type (TYPE_CODE_VOID
, 1, 0, "void",
8080 (struct objfile
*) NULL
));
8081 TYPE_NAME (builtin_type_ada_system_address
) = "system__address";
8083 add_language (&ada_language_defn
);
8086 (add_set_cmd ("varsize-limit", class_support
, var_uinteger
,
8087 (char *) &varsize_limit
,
8088 "Set maximum bytes in dynamic-sized object.",
8089 &setlist
), &showlist
);
8090 varsize_limit
= 65536;
8092 add_com ("begin", class_breakpoint
, begin_command
,
8093 "Start the debugged program, stopping at the beginning of the\n\
8094 main program. You may specify command-line arguments to give it, as for\n\
8095 the \"run\" command (q.v.).");
8099 /* Create a fundamental Ada type using default reasonable for the current
8102 Some object/debugging file formats (DWARF version 1, COFF, etc) do not
8103 define fundamental types such as "int" or "double". Others (stabs or
8104 DWARF version 2, etc) do define fundamental types. For the formats which
8105 don't provide fundamental types, gdb can create such types using this
8108 FIXME: Some compilers distinguish explicitly signed integral types
8109 (signed short, signed int, signed long) from "regular" integral types
8110 (short, int, long) in the debugging information. There is some dis-
8111 agreement as to how useful this feature is. In particular, gcc does
8112 not support this. Also, only some debugging formats allow the
8113 distinction to be passed on to a debugger. For now, we always just
8114 use "short", "int", or "long" as the type name, for both the implicit
8115 and explicitly signed types. This also makes life easier for the
8116 gdb test suite since we don't have to account for the differences
8117 in output depending upon what the compiler and debugging format
8118 support. We will probably have to re-examine the issue when gdb
8119 starts taking it's fundamental type information directly from the
8120 debugging information supplied by the compiler. fnf@cygnus.com */
8122 static struct type
*
8123 ada_create_fundamental_type (struct objfile
*objfile
, int typeid)
8125 struct type
*type
= NULL
;
8130 /* FIXME: For now, if we are asked to produce a type not in this
8131 language, create the equivalent of a C integer type with the
8132 name "<?type?>". When all the dust settles from the type
8133 reconstruction work, this should probably become an error. */
8134 type
= init_type (TYPE_CODE_INT
,
8135 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8136 0, "<?type?>", objfile
);
8137 warning ("internal error: no Ada fundamental type %d", typeid);
8140 type
= init_type (TYPE_CODE_VOID
,
8141 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8142 0, "void", objfile
);
8145 type
= init_type (TYPE_CODE_INT
,
8146 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8147 0, "character", objfile
);
8149 case FT_SIGNED_CHAR
:
8150 type
= init_type (TYPE_CODE_INT
,
8151 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8152 0, "signed char", objfile
);
8154 case FT_UNSIGNED_CHAR
:
8155 type
= init_type (TYPE_CODE_INT
,
8156 TARGET_CHAR_BIT
/ TARGET_CHAR_BIT
,
8157 TYPE_FLAG_UNSIGNED
, "unsigned char", objfile
);
8160 type
= init_type (TYPE_CODE_INT
,
8161 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8162 0, "short_integer", objfile
);
8164 case FT_SIGNED_SHORT
:
8165 type
= init_type (TYPE_CODE_INT
,
8166 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8167 0, "short_integer", objfile
);
8169 case FT_UNSIGNED_SHORT
:
8170 type
= init_type (TYPE_CODE_INT
,
8171 TARGET_SHORT_BIT
/ TARGET_CHAR_BIT
,
8172 TYPE_FLAG_UNSIGNED
, "unsigned short", objfile
);
8175 type
= init_type (TYPE_CODE_INT
,
8176 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8177 0, "integer", objfile
);
8179 case FT_SIGNED_INTEGER
:
8180 type
= init_type (TYPE_CODE_INT
, TARGET_INT_BIT
/ TARGET_CHAR_BIT
, 0, "integer", objfile
); /* FIXME -fnf */
8182 case FT_UNSIGNED_INTEGER
:
8183 type
= init_type (TYPE_CODE_INT
,
8184 TARGET_INT_BIT
/ TARGET_CHAR_BIT
,
8185 TYPE_FLAG_UNSIGNED
, "unsigned int", objfile
);
8188 type
= init_type (TYPE_CODE_INT
,
8189 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8190 0, "long_integer", objfile
);
8192 case FT_SIGNED_LONG
:
8193 type
= init_type (TYPE_CODE_INT
,
8194 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8195 0, "long_integer", objfile
);
8197 case FT_UNSIGNED_LONG
:
8198 type
= init_type (TYPE_CODE_INT
,
8199 TARGET_LONG_BIT
/ TARGET_CHAR_BIT
,
8200 TYPE_FLAG_UNSIGNED
, "unsigned long", objfile
);
8203 type
= init_type (TYPE_CODE_INT
,
8204 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8205 0, "long_long_integer", objfile
);
8207 case FT_SIGNED_LONG_LONG
:
8208 type
= init_type (TYPE_CODE_INT
,
8209 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8210 0, "long_long_integer", objfile
);
8212 case FT_UNSIGNED_LONG_LONG
:
8213 type
= init_type (TYPE_CODE_INT
,
8214 TARGET_LONG_LONG_BIT
/ TARGET_CHAR_BIT
,
8215 TYPE_FLAG_UNSIGNED
, "unsigned long long", objfile
);
8218 type
= init_type (TYPE_CODE_FLT
,
8219 TARGET_FLOAT_BIT
/ TARGET_CHAR_BIT
,
8220 0, "float", objfile
);
8222 case FT_DBL_PREC_FLOAT
:
8223 type
= init_type (TYPE_CODE_FLT
,
8224 TARGET_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8225 0, "long_float", objfile
);
8227 case FT_EXT_PREC_FLOAT
:
8228 type
= init_type (TYPE_CODE_FLT
,
8229 TARGET_LONG_DOUBLE_BIT
/ TARGET_CHAR_BIT
,
8230 0, "long_long_float", objfile
);
8237 ada_dump_symtab (struct symtab
*s
)
8240 fprintf (stderr
, "New symtab: [\n");
8241 fprintf (stderr
, " Name: %s/%s;\n",
8242 s
->dirname
? s
->dirname
: "?", s
->filename
? s
->filename
: "?");
8243 fprintf (stderr
, " Format: %s;\n", s
->debugformat
);
8244 if (s
->linetable
!= NULL
)
8246 fprintf (stderr
, " Line table (section %d):\n", s
->block_line_section
);
8247 for (i
= 0; i
< s
->linetable
->nitems
; i
+= 1)
8249 struct linetable_entry
*e
= s
->linetable
->item
+ i
;
8250 fprintf (stderr
, " %4ld: %8lx\n", (long) e
->line
, (long) e
->pc
);
8253 fprintf (stderr
, "]\n");